Sayfalar Arasında Koşullu Veri Aktarımı

[Feylosof]

İyi akşamlar diliyorum arkadaşlar.

Ekli dosyamda detaylı olarak anlatmaya çalıştım.
Sayfa 1 de "B" ile "AA" Sütun aralıklarında en az bir sütunda değer girilmiş bir dersi Sayfa2 de "A" sütununda karşılaştırma yaparak. Bu sayfanın "A" sütununda bulunmayan dersleri (varsa eğer )"B" sütununda listeleyecek.
İkinci seçenek olarak da Sayfa 2 de bulunup Sayfa1 den aynı kriterle süzülmüş olan derslerin içinde bulunmayan dersi "C" SÜTUNDA listeleyecek koda ihtiyacım var.
Desteğiniz için teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.
Sayfa1'in kod kısmına kopyalayıp çalıştırınız.

Sub test()
    Dim Bak As Long
    Dim SonSatir As Long
    
    With Worksheets("Sayfa2")
        .Range("B:B").Value = ""
        For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
            If WorksheetFunction.Sum(Range("B" & Bak & ":AA" & Bak)) > 0 Then
                If .Range("A:A").Find(what:=Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                    SonSatir = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                    If .Range("B1").Value = "" Then SonSatir = 1
                    .Cells(SonSatir, "B").Value = Cells(Bak, "A").Value
                End If
            End If
        Next
        .Range("C:C").Value = ""
        For Bak = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            If Range("A:A").Find(what:=.Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                SonSatir = .Cells(Rows.Count, "C").End(xlUp).Row + 1
                If .Range("C1").Value = "" Then SonSatir = 1
                .Cells(SonSatir, "C").Value = .Cells(Bak, "A").Value
            End If
        Next
    End With
    MsgBox "Tamamlandı."
End Sub

 

[Feylosof]

Sayın @Muzaffer Ali üstadım ilgi ve desteğiniz için çok teşekkür ederim.

1. Kod: B sütununa veriler doğru olarak gelmektedir.
Ancak
2. Kod: C sütununa veriler gelmedi.
b ve c sütunlarında veriler şöyle olmalı
Veriler ekran görüntüsündeki gibi olmalı

 

[Muzaffer Ali]

Bu kodu deneyin.

Sub test2()
    Dim Bak As Long
    Dim SonSatir As Long
    
    With Worksheets("Sayfa2")
        .Range("B:B").Value = ""
        .Range("C:C").Value = ""
        
        For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
            If WorksheetFunction.Sum(Range("B" & Bak & ":AA" & Bak)) > 0 Then
                If .Range("A:A").Find(what:=Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                    SonSatir = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                    If .Range("B1").Value = "" Then SonSatir = 1
                    .Cells(SonSatir, "B").Value = Cells(Bak, "A").Value
                End If
            ElseIf WorksheetFunction.Sum(Range("B" & Bak & ":AA" & Bak)) = 0 Then
                If Not .Range("A:A").Find(what:=Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                    SonSatir = .Cells(Rows.Count, "C").End(xlUp).Row + 1
                    If .Range("C1").Value = "" Then SonSatir = 1
                    .Cells(SonSatir, "C").Value = Cells(Bak, "A").Value
                End If
            End If
        Next
    End With
    MsgBox "Tamamlandı."
End Sub

 

[Feylosof]

Bu kodu deneyin.

Sub test2()
    Dim Bak As Long
    Dim SonSatir As Long
   
    With Worksheets("Sayfa2")
        .Range("B:B").Value = ""
        .Range("C:C").Value = ""
       
        For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
            If WorksheetFunction.Sum(Range("B" & Bak & ":AA" & Bak)) > 0 Then
                If .Range("A:A").Find(what:=Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                    SonSatir = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                    If .Range("B1").Value = "" Then SonSatir = 1
                    .Cells(SonSatir, "B").Value = Cells(Bak, "A").Value
                End If
            ElseIf WorksheetFunction.Sum(Range("B" & Bak & ":AA" & Bak)) = 0 Then
                If Not .Range("A:A").Find(what:=Cells(Bak, "A").Value, lookat:=xlWhole) Is Nothing Then
                    SonSatir = .Cells(Rows.Count, "C").End(xlUp).Row + 1
                    If .Range("C1").Value = "" Then SonSatir = 1
                    .Cells(SonSatir, "C").Value = Cells(Bak, "A").Value
                End If
            End If
        Next
    End With
    MsgBox "Tamamlandı."
End Sub

Çok teşekkür ederim. Emeğinize ve zihninize sağlık.