• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücrenin rengini değiştiren makro acil yardım

  • Konbuyu başlatan Konbuyu başlatan maskex
  • Başlangıç tarihi Başlangıç tarihi
M

maskex

Katılım
20 Nisan 2012
Mesajlar
78
Excel Vers. ve Dili
Ofis 365 TR 32 Bit
Merhaba arkadaşlar bir sahil şezlon şemamız var.Ben bu şezlongların takibi için otomatik renklendiren bir makro arıyorum.Dolu olunca kırmızı boşalınca mavi renk olacak. Örneğin 1 numaralı şezlonga tıklayınca kırmızı renk tekrar tıklayınca mavi renge geri dönecek. Yada farklı bir alternatifi varmıdır ? Herhangi bir yere bir işaret koyup bir numaralı şezlongu kırmızıya getirip onu silince maviye dönsün filan ?
Çok acil bir durum lütfen yardım..
 

Ekli dosyalar

Son düzenleme:
Merhaba,
Dosyanız ilişiktedir.
Önce şezlongların tümünü örnekte olduğu gibi mavi yapın.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
    If Target <> "" Then
        If Target.Interior.ColorIndex = 41 Then
            Target.Interior.ColorIndex = 3
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
        End If
    End If
End Sub
 

Ekli dosyalar

Ellerine sağlık çok teşekürler. Peki örneğin tıklayınca kırmızı olunca pencere açılca ve ben oraya bilgi yazsam enter desem bunu 2.sayfaya kaydebilirmi.
Yada sayfada hangi şejlong kaç defa kırmızı olmuş bunu 2. sayfadya saydırabiliriyiz
 
Merhaba,
Kodun işlevini yapması için, Sheet2 A sütununa şezlong numaralarınızı yazmalısınız.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target <> "" Then
    If Target.Interior.ColorIndex = 41 Then
        Set Aranan = Sheets("Sheet2").Range("A:A").Find(Target, , xlValues, xlWhole)
        If Not Aranan Is Nothing Then
           Sor = MsgBox("Şezlong kullanıldı olarak kaydedilsin mi?", vbYesNo, "UYARI")
            If Sor = vbYes Then
                Sheets("Sheet2").Cells(Aranan.Row, 2).Value = Sheets("Sheet2").Cells(Aranan.Row, 2).Value + 1
                Target.Interior.ColorIndex = 3
                Exit Sub
            End If
        End If
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
    End If
End If
End Sub
 
dEdE' Alıntı:
Merhaba,
Kodun işlevini yapması için, Sheet2 A sütununa şezlong numaralarınızı yazmalısınız.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target <> "" Then
    If Target.Interior.ColorIndex = 41 Then
        Set Aranan = Sheets("Sheet2").Range("A:A").Find(Target, , xlValues, xlWhole)
        If Not Aranan Is Nothing Then
           Sor = MsgBox("Şezlong kullanıldı olarak kaydedilsin mi?", vbYesNo, "UYARI")
            If Sor = vbYes Then
                Sheets("Sheet2").Cells(Aranan.Row, 2).Value = Sheets("Sheet2").Cells(Aranan.Row, 2).Value + 1
                Target.Interior.ColorIndex = 3
                Exit Sub
            End If
        End If
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
    End If
End If
End Sub
Genişletmek için tıkla ...

Tmm abicim allah ne muradın varsa versin çok sağol..yaptım
 
Peki ben şezlonga tıkladığımda bana bu soru sorduğu gibi pencere gelse ben oraya oda numarasını yazsam ve kullanıldı sorusuna evet desem 2. sayfada saysa ve bu yazdığım yazı yada numara neyse onu c sütununa ilgili şejlongun yanına yazsa böyle birşey mümkün mü ?
 
Merhaba,
Şunu deneyelim.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target <> "" Then
    If Target.Interior.ColorIndex = 41 Then
        Set Aranan = Sheets("Sheet2").Range("A:A").Find(Target, , xlValues, xlWhole)
        If Not Aranan Is Nothing Then
            OdaNo = Application.InputBox("Lütfen Oda Numarasını Yazınız.", "ODA NUMARASI GİRİŞİ")
            If OdaNo = False Then Exit Sub
            Sor = MsgBox("Şezlong kullanıldı olarak kaydedilsin mi?", vbYesNo, "UYARI")
            If Sor = vbYes Then
                Sheets("Sheet2").Cells(Aranan.Row, 2).Value = Sheets("Sheet2").Cells(Aranan.Row, 2).Value + 1
                Sheets("Sheet2").Cells(Aranan.Row, 3).Value = OdaNo
                Target.Interior.ColorIndex = 3
                Exit Sub
            End If
        End If
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
    End If
End If
End Sub
 
dEdE' Alıntı:
Merhaba,
Şunu deneyelim.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target <> "" Then
    If Target.Interior.ColorIndex = 41 Then
        Set Aranan = Sheets("Sheet2").Range("A:A").Find(Target, , xlValues, xlWhole)
        If Not Aranan Is Nothing Then
            OdaNo = Application.InputBox("Lütfen Oda Numarasını Yazınız.", "ODA NUMARASI GİRİŞİ")
            If OdaNo = False Then Exit Sub
            Sor = MsgBox("Şezlong kullanıldı olarak kaydedilsin mi?", vbYesNo, "UYARI")
            If Sor = vbYes Then
                Sheets("Sheet2").Cells(Aranan.Row, 2).Value = Sheets("Sheet2").Cells(Aranan.Row, 2).Value + 1
                Sheets("Sheet2").Cells(Aranan.Row, 3).Value = OdaNo
                Target.Interior.ColorIndex = 3
                Exit Sub
            End If
        End If
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
    End If
End If
End Sub
Genişletmek için tıkla ...

Kesinlikle çok güzel ancak örneğin 15 numaralı şejlon kullanıldı ve numara c sütununa otomatik yazdı sonra tekrar boşaldı 2. kez kullanıldığında 2. kişinin bilgisi yine c sütununa yazıldığından ilk veri gidiyor bunu her yeni girilen oda 2. sayfada numarası ilgili şejlongun yanına c sütuna 2. misafir d sütununa diye yan yana yazması mümkünmüdür ?
 
Merhaba,
Aşağıdaki kodu dener misiniz?

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target <> "" Then
    If Target.Interior.ColorIndex = 41 Then
        Set Aranan = Sheets("Sheet2").Range("A:A").Find(Target, , xlValues, xlWhole)
        If Not Aranan Is Nothing Then
            OdaNo = Application.InputBox("Lütfen Oda Numarasını Yazınız.", "ODA NUMARASI GİRİŞİ")
            If OdaNo = False Then Exit Sub
            Sor = MsgBox("Şezlong kullanıldı olarak kaydedilsin mi?", vbYesNo, "UYARI")
            If Sor = vbYes Then
            Sheets("Sheet2").Cells(Aranan.Row, 2).Value = Sheets("Sheet2").Cells(Aranan.Row, 2).Value + 1
                sk = Sheets("Sheet2").Rows(Aranan.Row).Find("*", , , , xlByColumns, xlPrevious).Column + 1
                Sheets("Sheet2").Cells(Aranan.Row, sk).Value = OdaNo
                Target.Interior.ColorIndex = 3
                Exit Sub
            End If
        End If
        ElseIf Target.Interior.ColorIndex = 3 Then
            Target.Interior.ColorIndex = 41
    End If
End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst