VBA İlgili Satırı Diğer Sayfaya Kopyalama

[mrsmbay]

Merhabalar. Örnek dosyada da görüleceği üzere satırın yanına eklediğim onay kutusuna tıklayınca ilgili satır izinli ve kırmızı olarak görünüyor. Onay kutusuna tıkladıktan sonra ilgili hücreleri diğer sayfadaki tabloya kopyalamasını istiyorum. Formülle bir çözüm bulamadığım için vba ile yardımcı olabilirseniz çok sevinirim şimdiden teşekkür ederim.

 

[ÖmerFaruk]

Onay kutusunu tıklayıp onayı kaldırınca birşey yapacak mı?

 

[mrsmbay]

Hocam onayı kaldırdıktan sonra bir işlem yapmasına gerek yok. Benim amacım burada kopyala yapıştır işlemini azaltmak. Personel izinden döndükten sonra izin tablosundan isimleri silmem yeterli olur.

 

[ÖmerFaruk]

Onay kutusunu yanlışlıkla tıklama durumunuzda KODLAR tıklanan ismi listeye ekleyecek.
Yanlışı farkedip onayı kaldırınca listeden silinmeyecek mi?

 

[mrsmbay]

Hocam tekrar tıklayınca listeden kaldırması güzel olur tabi ki açıkçası sizi daha fazla uğraştırmak istemedim ama oraya kopyalanan ismin tekrar tıkladıktan sonra kalkması daha güzel olur.

 

[ÖmerFaruk]

Sayfanıza buton ya da şekil ekleyin. Aşağıdaki kodu bir modüle içine koyup butona bu makroyu atayın.
Onay butonlarını arzu ettiğiniz gibi işaretledikten sonra butona basın

Sub izinkaydet()
    Dim DictList As Scripting.Dictionary, Sh As Worksheet, Son As Long, i As Long, k As Byte, KaydedilecekVeri, KayıtlıVeri, Liste()
    Son = Range("B" & Rows.Count).End(3).Row
    If Son < 3 Then MsgBox "Liste boş": Exit Sub
    KaydedilecekVeri = Range("B3:D" & Son).Value
    Set Sh = Worksheets("İZİN")
    Son = Sh.Range("B" & Rows.Count).End(3).Row
    KayıtlıVeri = Sh.Range("B2:D" & Son).Value
    Set DictList = New Scripting.Dictionary
    For i = 2 To UBound(KayıtlıVeri)
        If Not DictList.Exists(KayıtlıVeri(i, 1)) Then DictList.Add KayıtlıVeri(i, 1), KayıtlıVeri(i, 2) & " xx " & KayıtlıVeri(i, 3)
    Next i
    Sh.Range("B3:D" & DictList.Count + 3).ClearContents
    For i = 1 To UBound(KaydedilecekVeri)
        If Not DictList.Exists(KaydedilecekVeri(i, 1)) Then
            If KaydedilecekVeri(i, 3) = "İZİNLİ" Then DictList.Add KaydedilecekVeri(i, 1), KaydedilecekVeri(i, 2)
        Else
            If KaydedilecekVeri(i, 3) <> "İZİNLİ" Then DictList.Remove KaydedilecekVeri(i, 1)
        End If
    Next i
    ReDim Liste(1 To DictList.Count, 1 To 3)
    For i = 1 To DictList.Count
        Liste(i, 1) = DictList.Keys()(i - 1)
        For k = 0 To UBound(Split(DictList.Items()(i - 1), " xx "))
            Liste(i, k + 2) = Split(DictList.Items()(i - 1), " xx ")(k)
        Next k
    Next i
    If DictList.Count > 0 Then Sh.Range("B3:D" & DictList.Count + 2) = Liste
    Set DicList = Nothing: Set Sh = Nothing: Erase KayıtlıVeri: Erase KaydedilecekVeri: Erase Liste
End Sub

 

[mrsmbay]

Hocam makroyu çalıştırdığımda hata veriyor bir de bunu onay kutusuna tıkladığımda yapması mümkün mü acaba ?

 

[ÖmerFaruk]

Excel dosyanızda VBA penceresinde Tools /Reference altında aşağıdaki resimde görülen en alttaki seçeneği Microsoft Scrripting Runtime sizin listeden bulup aktif edin.



Fazladan bir butona basınca daha kararlı oluyor. Aksi durumda farklı bir kod yazmak gerekiyor.

 

[mrsmbay]

Hocam emeğinize teşekkür ederim öncelikle. Şimdi de şu satırda uyarı veriyor herhangi bir işlem yapmıyor
ReDim Liste(1 To DictList.Count, 1 To 3)

 

[ÖmerFaruk]

Sanırım tüm listeyi sıfırladınız.
O satırın hemen üstüne aşağıdaki satırı ilave edin lütfen.

If DictList.Count = 0 Then Exit Sub

 

[mrsmbay]

Hocam dediğiniz gibi yaptım fakat atadığım butona tıkladıktan sonra onay kutusunu işaretliyorum oraya herhangi bir kopyalama yapmıyor.

 

[ÖmerFaruk]

Önce ONAY TUŞLARI na basın sonra YENİ BUTONA

 

[mrsmbay]

Hocam çalışıyor çok teşekkür ederim biraz zahmet oldu ama kusuruma bakmayın emeğinize sağlık

 

[ÖmerFaruk]

Teşekkürler. Kolay gelsin.