A sütununda olmayan verileri makro ile yazdır

[şehiriçi]

Merhaba ,
Arkadaşlar ekte vermiş olduğum dosyamın A sütunundaki veriler ,eksiksiz full verilerdir. Ancak B,C,D...diye devam eden diğer sütunlar ise A sütununa göre eksik verilerdir. Ben manuel olarak bu eksik sütunların A sütununa göre eksik olan verilerini ,her eksik sütunun 23. satırından itibaren manuel olarak yazdım (sarı zemin renk), siz değerli dostlarımdan manuel olarak yazmış olduğum bu verileri makro ile yazmanız , ayıracağınız zaman ve vereceğiniz emek için şimdiden teşekkür ederim .

 

[Necdet]

Merhaba,
Dener misiniz?

Sub Bul()

Dim j As Integer
Dim i As Integer
Dim k As Integer

Dim arr As Variant
Dim rng As Range
Dim c As Range

Application.ScreenUpdating = False

Rows("23:46").ClearContents

arr = Range("A2:A" & Cells(Rows.Count, "a").End(3).Row).Value

For j = 2 To Cells(1, Columns.Count).End(1).Column
    k = 22
    Set rng = Range(Cells(1, j), Cells(22, j))
    For i = LBound(arr, 1) To UBound(arr, 1)
        Set c = rng.Find(arr(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If c Is Nothing Then
            k = k + 1
            Cells(k, j) = arr(i, 1)
        End If
    Next i
Next j

Application.ScreenUpdating = True

MsgBox "İşlem Tamam...."

End Sub

 

[ÖmerFaruk]

Alternatif olsun

Sub EksikleriBul()
    Dim AnaListe(), Liste()
    AnaListe = Range("A3:A" & Range("A3").End(xlDown).Row).Value

    For k = 2 To Range("B1").End(xlToRight).Column
        SonSat = WorksheetFunction.Min(22, Range("A3").Offset(, k - 1).End(xlDown).Row)
        Liste = Range("B3").Offset(, k - 2).Resize(UBound(AnaListe), 1).Value
        ReDim Yaz(1 To UBound(Liste, 1), 1 To 1)
        x = 0
        Say = 0
        For i = LBound(AnaListe, 1) To UBound(AnaListe, 1)
            x = x + 1
            If AnaListe(i, 1) <> Liste(x, 1) Then
                Say = Say + 1
                Yaz(Say, 1) = AnaListe(i, 1)
                x = x - 1
            End If
        Next i
        Range("B23").Offset(, k - 2).Resize(6, 1).ClearContents
        Range("B23").Offset(, k - 2).Resize(Say, 1) = Yaz
    Next k
End Sub

 

[şehiriçi]

Merhaba ,
ÖmerFaruk Hocam elinize ,emeğinize sağlık gerçekten mükemmel kurgulanmış bir kod yığını , yazdığınız koddaki diziler olsun fonksiyonlar olsun bildiğim halde kodu çözüp anlayıncaya kadar neredeyse 1 saatim geçti ,çok teşekkürler .
Necdet Hocam sizede çok teşekkür ediyorum ,sağolun varolun ,ancak sizin emek verip yazdığınız kod soruma doğru cevap vermiyor. Sizin yazdığınız koddaki mantığı scripting.dictionary yöntemine benziyor , o açıdan beni hem find komutunu daha detaylı öğrenmeye teşvik etmiş oldunuz hemde scripting dictionary harici benzer bir yöntemi göstermiş oldunuz .
İyiki varsınız ,sağlıkla kalın

 

[şehiriçi]

Tekrar Merhaba ,
ÖmerFaruk beyin verdiği kodu dosyama uyarlamaya çalıştım ama bir yerde hata yapıyorum , hatamı bulmamda desteğinizi bekliyorum , teşekkürler .

 

[ÖmerFaruk]

Soru bir hayli değişmiş.

Sub EksikleriBul()
    
    Dim hat As Worksheet, fark As Worksheet
    Dim AnaListe(), Liste()
    Dim k As Integer, mz As Integer, x As Integer, i As Integer, SonSat As Integer
    Dim say As Integer, a As Integer
    Dim HatBul As Range
    
    Set hat = Sheets("hat")
    Range("A23:XFD" & Rows.Count).ClearContents
    For k = 1 To Range("A2").End(xlToRight).Column
        Set HatBul = hat.Rows(2).Find(Cells(2, k))
        If HatBul Is Nothing Then GoTo NextHat
        SonSat = hat.Cells(Rows.Count, HatBul.Column).End(xlUp).Row
        If SonSat < 3 Then GoTo NextHat
        AnaListe = HatBul.Offset(1, 0).Resize(SonSat - 2, 1).Value
        Liste = Cells(3, k).Resize(UBound(AnaListe), 1).Value
        ReDim Yaz(1 To UBound(Liste, 1), 1 To 1)
        x = 1
        say = 0
        For i = LBound(AnaListe, 1) To UBound(AnaListe, 1)
            x = x + 1
            If AnaListe(i, 1) <> Liste(x, 1) Then
                say = say + 1
                Yaz(say, 1) = AnaListe(i, 1)
                x = x - 1
            End If
        Next i
        Cells(23, k).Resize(say, 1) = Yaz
NextHat:
    Next k
End Sub

 

[şehiriçi]

ÖmerFaruk Hocam Desteğiniz için Teşekkürler , verdiğiniz kod ile istediğimi elde ettim .
dosyamın son halinide yükleyerek hoşçakalın diyorum.