Aynı sayfadaki verileri karşılaştırma

[fdisk]

Arkadşalr aynı sayfadaki A ve B sutunundaki verilerle D ve E sutunundaki verileri karşılaştırıp G sutununa A ve D sutunundakileri B sutunundakileri H sutununa E dekileride I sutununa Yazmasını istiyorum. bide A olupda D de olmayanları, D olup Aolmayanlarıda G yazmasını istiyorum. Teşekkür ederim.

Örnek Dosya ekte

 

[Orion1]

Arkadşalr aynı sayfadaki A ve B sutunundaki verilerle D ve E sutunundaki verileri karşılaştırıp G sutununa A ve D sutunundakileri B sutunundakileri H sutununa E dekileride I sutununa Yazmasını istiyorum. bide A olupda D de olmayanları, D olup Aolmayanlarıda G yazmasını istiyorum. Teşekkür ederim.

Örnek Dosya ekte

Hiç bir şey anlamadım.

 

[fdisk]

Hiç bir şey anlamadım.

hoçam ekteki dosyada nasıl olmasını istediğim sarı olarak işaretledim.

 

[Orion1]

Ekli dosyayı inceleyiniz.
Butona basınız.

Sub karsilastir()
Dim i, k, sat As Long
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
Range("G2:I65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "A").End(xlUp).Row
    Cells(sat, "G").Value = Cells(i, "A").Value
    Cells(sat, "H").Value = Cells(i, "B").Value
    sat = sat + 1
Next i
For k = 2 To Cells(65536, "D").End(xlUp).Row
    Set j = Range("G2:G65536").Find(Cells(k, "D").Value, , xlValues, xlWhole)
    If j Is Nothing Then
        Cells(sat, "H").Value = Cells(k, "D").Value
        Cells(sat, "I").Value = Cells(k, "E").Value
        Else
        Cells(j.Row, "I").Value = Cells(k, "E").Value
    End If
Next k
Application.ScreenUpdating = True
Set j = Nothing
MsgBox "İşlem Tamam", vbOKOnly + vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Sub VERİLERİ_KARŞILAŞTIR()
    Range("G2:I65536").ClearContents
    Range("A2:A" & [A65536].End(3).Row).Copy Range("G2")
    Range("D2:D" & [D65536].End(3).Row).Copy Range("G65536").End(3).Offset(1)
    Range("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("IV1"), Unique:=True
    Range("G2:I65536").ClearContents
    Range("IV1:IV" & [IV65536].End(3).Row).Copy Range("G1")
    Range("IV:IV").Clear
    Range("H2").Formula = "=IF(ISERROR(VLOOKUP(G2,$A$2:$B$65536,2,0)),"""",VLOOKUP(G2,$A$2:$B$65536,2,0))"
    Range("I2").Formula = "=IF(ISERROR(VLOOKUP(G2,$D$2:$E$65536,2,0)),"""",VLOOKUP(G2,$D$2:$E$65536,2,0))"
    Range("H2:I2").AutoFill Destination:=Range("H2:I" & [G65536].End(3).Row)
    Range("H2:I" & [G65536].End(3).Row) = Range("H2:I" & [G65536].End(3).Row).Value
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[fdisk]

Hepinize çok teşekkür ederim.
Sağolun Arkadaşlar. çok işeme yaradı

 

[fdisk]

Ekli dosyayı inceleyiniz.
Butona basınız.

Sub karsilastir()
Dim i, k, sat As Long
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
Range("G2:I65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "A").End(xlUp).Row
    Cells(sat, "G").Value = Cells(i, "A").Value
    Cells(sat, "H").Value = Cells(i, "B").Value
    sat = sat + 1
Next i
For k = 2 To Cells(65536, "D").End(xlUp).Row
    Set j = Range("G2:G65536").Find(Cells(k, "D").Value, , xlValues, xlWhole)
    If j Is Nothing Then
        Cells(sat, "H").Value = Cells(k, "D").Value
        Cells(sat, "I").Value = Cells(k, "E").Value
        Else
        Cells(j.Row, "I").Value = Cells(k, "E").Value
    End If
Next k
Application.ScreenUpdating = True
Set j = Nothing
MsgBox "İşlem Tamam", vbOKOnly + vbInformation
End Sub

hocam bunda D sutunundaki 10 cu satırdakilerden sonrasını almıyor en son satırı ekliyor.
saygılarımla.

 

[Orion1]

hocam bunda D sutunundaki 10 cu satırdakilerden sonrasını almıyor en son satırı ekliyor.
saygılarımla.

Pardon teknik bir arıza olmuş.Kodu düzelttim.Şimdi deneyebilirsiniz.

Sub karsilastir()
Dim i, k, sat As Long
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
Range("G2:I65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "A").End(xlUp).Row
    Cells(sat, "G").Value = Cells(i, "A").Value
    Cells(sat, "H").Value = Cells(i, "B").Value
    sat = sat + 1
Next i
For k = 2 To Cells(65536, "D").End(xlUp).Row
    Set j = Range("G2:G65536").Find(Cells(k, "D").Value, , xlValues, xlWhole)
    If j Is Nothing Then
        Cells(sat, "G").Value = Cells(k, "D").Value
        Cells(sat, "I").Value = Cells(k, "E").Value
        sat = sat + 1
        Else
        Cells(j.Row, "I").Value = Cells(k, "E").Value
    End If
Next k
Application.ScreenUpdating = True
Set j = Nothing
MsgBox "İşlem Tamam", vbOKOnly + vbInformation
End Sub

 

[fdisk]

sağol ellerine sağlık

 

[KARANLIKLAR_LORDU]

KarŞilaŞtirma Yapmak İstİyorum Yardim Edersenİz Sevİnİrİm

KarŞilaŞtirma Konusunda Yardima İhtİyacim Var Ektekİ Dosyanin İÇİndede AÇiklamalar Mevcuttur. İsİmler Kodlar Fİyat Ve Mİktarlar Var Sirasi KariŞik Olanlari Ayni Hİzada Toplamak Ve Yan Yana Yazmak İstİyorum Bununla İlgİlİ Bİr FormÜl Varmidir Yoksa Makro İle Yapabİlİrmİsİnİz.

 

[Ferhat Pazarçevirdi]

Merhabalar,

E3 hücresine; =DÜŞEYARA(B3;$F$3:$H$23;3;YANLI&#350 formülünü girin ve aşağıya doğru kopyalayın. Fiyatların yanına Miktarlar da gelecektir.