DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
yardımcı olabilcek yokmu
Private Sub CommandButton1_Click()
Range("a2:b65000").Interior.ColorIndex = xlNone
For a = 2 To [a65536].End(3).Row
x = 1
Cells(a, "a") = LTrim(Cells(a, "a"))
If WorksheetFunction.CountIf(Range("b2:b65000"), Cells(a, "a")) > 0 Then
b = WorksheetFunction.CountIf(Range("b2:a65000"), Cells(a, "a"))
For c = 1 To b
Set d = Range("b" & x + 1 & ":b65000").Find(What:=Cells(a, "a"), LookIn:=xlValues)
If Not d Is Nothing Then
Cells(d.Row, "b").Interior.ColorIndex = 6
Cells(a, "a").Interior.ColorIndex = 6
x = d.Row
End If: Next: End If:
Cells(a, "a") = " " & Cells(a, "a")
Next
End Sub
Aşağıdaki kodları (Sayfa1 e buton ekleyerek) deneyin.
Kod:Private Sub CommandButton1_Click() Range("a2:b65000").Interior.ColorIndex = xlNone For a = 2 To [a65536].End(3).Row x = 1 Cells(a, "a") = LTrim(Cells(a, "a")) If WorksheetFunction.CountIf(Range("b2:b65000"), Cells(a, "a")) > 0 Then b = WorksheetFunction.CountIf(Range("b2:a65000"), Cells(a, "a")) For c = 1 To b Set d = Range("b" & x + 1 & ":b65000").Find(What:=Cells(a, "a"), LookIn:=xlValues) If Not d Is Nothing Then Cells(d.Row, "b").Interior.ColorIndex = 6 Cells(a, "a").Interior.ColorIndex = 6 x = d.Row End If: Next: End If: Cells(a, "a") = " " & Cells(a, "a") Next End Sub
Ek dosyayı inceleyin.Makro ekleyemedim ama ben bi yerde hatamı yapıyorum