Soru boş olmayanları kopyalama

[ogzcntrk]

sayfa1 de bulunan listedeki kişilerin tarih sırasına göre sayfa2 deki alanlara kopyalatmak istiyorum. Ben yapamadım. örnek dosya mevcuttur. Yardım ederseniz sevinirim.

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub ceteleme()
Set s1 = Sheets("CETELEME")
Set s2 = Sheets("liste")
s2.[B2:AF12].ClearContents
For gun = 2 To 32
    If IsDate(s1.Cells(2, gun)) = True Then
        For kisi = 3 To 14
            If s1.Cells(kisi, gun) <> "" Then
                yeni = s2.Cells(Rows.Count, gun).End(3).Row + 1
                s2.Cells(yeni, gun) = s1.Cells(kisi, "A") & "-" & s1.Cells(kisi, gun)
            End If
        Next
    End If
Next
s2.Activate
MsgBox "İşlem tamamlandı :)", vbInformation
End Sub

 

[ogzcntrk]

Hemen deniyorum.

 

[ogzcntrk]

çok teşekkür ediyorum YUSUF44. Elinize sağlık makro çok güzel bir şekilde çalışıyor.

 

[ogzcntrk]

@YUSUF44 rica etsem müsait olursanız, bu kodu 8, 16, 24 olarak sıralı ve g kişisini kopyalamamak için yeniden düzenleyebilir miyiz?

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub ceteleme()
Set s1 = Sheets("CETELEME")
Set s2 = Sheets("liste")
s2.[B2:AF12].ClearContents
For gun = 2 To 32
    If IsDate(s1.Cells(2, gun)) = True Then
        For kisi = 3 To 14
            If s1.Cells(kisi, "A") <> "G" And s1.Cells(kisi, gun) <> "" Then
                If s1.Cells(kisi, gun) = 8 Then
                    yeni = s2.Cells(Rows.Count, gun).End(3).Row + 1
                    s2.Cells(yeni, gun) = s1.Cells(kisi, "A") & "-" & s1.Cells(kisi, gun)
                End If
            End If
        Next
        For kisi = 3 To 14
            If s1.Cells(kisi, "A") <> "G" And s1.Cells(kisi, gun) <> "" Then
                If s1.Cells(kisi, gun) = 16 Then
                    yeni = s2.Cells(Rows.Count, gun).End(3).Row + 1
                    s2.Cells(yeni, gun) = s1.Cells(kisi, "A") & "-" & s1.Cells(kisi, gun)
                End If
            End If
        Next
        For kisi = 3 To 14
            If s1.Cells(kisi, "A") <> "G" And s1.Cells(kisi, gun) <> "" Then
                If s1.Cells(kisi, gun) = 24 Then
                    yeni = s2.Cells(Rows.Count, gun).End(3).Row + 1
                    s2.Cells(yeni, gun) = s1.Cells(kisi, "A") & "-" & s1.Cells(kisi, gun)
                End If
            End If
        Next
    End If
Next
s2.Activate
MsgBox "İşlem tamamlandı :)", vbInformation
End Sub

 

[ogzcntrk]

Hızır gibi yetiştiniz. Yazdığınız makro çok güzel çalışıyor. Çok teşekkürler.