Makroyla Düşeyara

[salih31]

Sayfa1'de A sütününda ki verileri Sayfa2de A sütününda olan verilerle karşılaştırıp aynı olan veriler varsa safta 2 deki B sutunu verilerini sayfa 1 deki B sununa aktarmayı makroda yapabilirmisiniz.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir Modul'e kopyalayıp deneyiniz.

Birden fazla aynı veri varsa Sayfa1'in B sütununa hepsini listeler.

Sub Karsilastir()

    Dim s1  As Worksheet, _
        s2  As Worksheet, _
        c   As Range, _
        i   As Long, _
        Adr As String
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    s1.Range("B:B").ClearContents

    s1.Columns("A:A").Replace What:=" ", Replacement:=""
    s2.Columns("A:A").Replace What:=" ", Replacement:=""
   
    For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
        
        With s2.Range("A:A")
            Set c = .Find(s1.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    If Len(s1.Cells(i, "B")) = 0 Then
                        s1.Cells(i, "B") = s2.Cells(c.Row, "B")
                    Else
                        s1.Cells(i, "B") = s1.Cells(i, "B") & " * " & s2.Cells(c.Row, "B")
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Karşılaştırma Bitmiştir", vbInformation, "Excel.web.tr"
    
End Sub

 

[salih31]

teşekkürler.. birde bazen 34 LL 42 şeklinde boşluklu veya 34LL42 boşluksuz olarak yazılma durumunda karşılaştırmada bunu aynısı olarak görmüyor bunu nasıl çözebiliriz harfler veya rakamlar arası boşlukları görmeden tarama yapabilirmi?

 

[Necdet]

Merhaba,

Her iki sayfadaki sütunlarda da boşluk karakterini kaldırın.

Sütunu seçin
Ctrl+H
Aranan (Bir boşluk)
Yerine konan için bir şey yazmayın
Tümünü Değiştir.

 

[numan şamil]

Necdet beyin affına sığınarak
şeklinde olabilir mi?

Sub Karsilastir()

    Dim s1  As Worksheet, _
        s2  As Worksheet, _
        c   As Range, _
        i   As Long, _
        Adr As String
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    For x = 2 To s1.Cells(Rows.Count, "A").End(xlUp).Row
s1.Cells(x, "A") = Replace(s1.Cells(x, "A"), " ", "")
Next x
For x = 2 To s2.Cells(Rows.Count, "A").End(xlUp).Row
s2.Cells(x, "A") = Replace(s2.Cells(x, "A"), " ", "")
Next x
    s1.Range("B:B").ClearContents
    
    For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
        
        With s2.Range("A:A")
            Set c = .Find(s1.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    If Len(s1.Cells(i, "B")) = 0 Then
                        s1.Cells(i, "B") = s2.Cells(c.Row, "B")
                    Else
                        s1.Cells(i, "B") = s1.Cells(i, "B") & " * " & s2.Cells(c.Row, "B")
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Karşılaştırma Bitmiştir", vbInformation, "Excel.web.tr"
    
End Sub

 

[salih31]

Necdet bey ve Numan bey çok teşekkür ederim saygılar.

 

[Necdet]

Merhaba,

Boşlukları silmek için döngüye gerek yok, excel'in olanaklarını kullanmak daha hızlı olur.

2 nolu mesajda boşlukları silen kodları ekledim.
Sayın Numan Şamil'in katkısına da teşekkür ederim.

 

[numan şamil]

Merhaba,

Boşlukları silmek için döngüye gerek yok, excel'in olanaklarını kullanmak daha hızlı olur.

2 nolu mesajda boşlukları silen kodları ekledim.
Sayın Numan Şamil'in katkısına da teşekkür ederim.

Yaptığınız bilgilendirme için teşekkür ederim.

 

[nongeyikm]

Harikasınız