Karışık listede aynı olanlar karşılıklı sırada düzenleyebilirmiyiz.

[NADİR YILDIZ]

ekli, dosyayı incelerseniz sorumu daha iyi anlamış olursunuz.bu konuda bana yardımcı olurmusunuz.

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.

Sub karsilastir()
Dim sat As Long, i As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("J5:L5").ClearContents
Range("J4").Value = "SIRA"
Range("K4").Value = "AÇIKLAMA"
Range("L4").Value = "TUTAR"
sat = 1
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
For i = 5 To 25
    Set k = Range("H5:H25").Find(Cells(i, "C").Value, , xlValues, xlWhole)
        If Not k Is Nothing Then
            Cells(i, "K").Value = k.Value
            Cells(i, "L").Value = Cells(k.Row, "I").Value
            Else
            Cells(i, "K").Value = Cells(i, "C").Value
            Cells(i, "L").Value = Cells(i, "D").Value
        End If
        Cells(i, "J").Value = sat
        sat = sat + 1
Next i
sonsat = Cells(25, "K").End(xlUp).Row + 1
For i = 5 To Cells(25, "H").End(xlUp).Row
    Set c = Range("K5:K25").Find(Cells(i, "H").Value, , xlValues, xlWhole)
    If c Is Nothing Then
        Cells(sonsat, "K").Value = Cells(i, "H").Value
        Cells(sonsat, "L").Value = Cells(i, "I").Value
        sonsat = sonsat + 1
    End If
Next
Range("J5:L25").Cut
Range("G5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set k = Nothing
Set c = Nothing
Range("A1").Select
MsgBox "İŞLEM TAMAMDIR.", vbOKOnly + vbInformation, Application.UserName
End Sub