Liste Karşılaştırma

[osmanak]

Ekteki Excel dosyasında olması gereken karşılaştırma örneğini gösterdim.
Benim istediğim “fatura” sayfasının D sütunundaki “aranan no” ile;
“telno” sayfasının C,D,E,F sütunlarındaki “özel noların”
Karşılaştırılarak, “özel no” da olan “aranan no” ların (“fatura” sayfasındaki ), yanındaki diğer bilgiler ile “sonuc” sayfasına aktarılması, “telno” sayfasından da karşılık gelen ad soyad bilgisinin aktarılmasıdır.
Mümkünse “fatura” sayfasında “özel no” ile karşılığı olanların sarı vurgu renk, olmayanların ise kırmızı vurgu renge boyansa çok güzel olur..
Yardımlarınızı bekliyorum…

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları kopyalayarak çalıştırınız.

Option Explicit
Sub OzelNoAyir()
Dim shF As Worksheet, shT As Worksheet, shs As Worksheet
Dim arrF() As Variant
Dim arrT() As Variant
Dim Fsayi As Integer
Dim i%, j%, y%, x%, sonS%
Dim hcr As Range
Set shF = Sheets("fatura")
Set shT = Sheets("telno")
Set shs = Sheets("sonuc")
Fsayi = shF.Cells(65536, 1).End(xlUp).Row - 1
ReDim arrF(1 To Fsayi, 1 To 6)
For i = 2 To Fsayi + 1
    For j = 1 To 6
        arrF(i - 1, j) = shF.Cells(i, j)
    Next j
Next i
For Each hcr In shT.Range("C2:F" & shT.Cells(65536, 1).End(xlUp).Row).Cells
    If IsEmpty(hcr) = False Then: y = y + 1
Next
ReDim arrT(1 To y + 1, 1 To 2)
For Each hcr In shT.Range("C2:F" & shT.Cells(65536, 1).End(xlUp).Row).Cells
    If IsEmpty(hcr) = False Then
       x = x + 1
       arrT(x, 1) = hcr
       arrT(x, 2) = shT.Cells(hcr.Row, 2)
    End If
Next
If shs.Cells(65536, 1).End(xlUp).Row > 1 Then
   shs.Range("A2:A" & shs.Cells(65536, 1).End(xlUp).Row).ClearContents
End If
For i = 1 To UBound(arrF)
    For j = 1 To UBound(arrT)
        If arrF(i, 4) = arrT(j, 1) Then
           sonS = shs.Cells(65536, 1).End(xlUp).Row + 1
           shs.Cells(sonS, 1) = arrF(i, 1)
           shs.Cells(sonS, 2) = arrF(i, 2)
           shs.Cells(sonS, 3) = arrF(i, 3)
           shs.Cells(sonS, 4) = arrF(i, 4)
           shs.Cells(sonS, 5) = arrF(i, 5)
           shs.Cells(sonS, 6) = arrF(i, 6)
           shs.Cells(sonS, 7) = arrT(j, 2)
        End If
    Next j
Next i
shs.Cells(sonS + 1, 4) = "Genel Toplam"
shs.Cells(sonS + 1, 5).Formula = "=SUM(E2:E" & sonS & ")"
shs.Select
Set shF = Nothing
Set shs = Nothing
Set shT = Nothing
End Sub

 

[osmanak]

öncelikle ilgilendiğiniz için çok teşekkür ederim..
kodu denedim gayet güzel çalışıyor..ancak bir iki şey diyeceğim ;
1-"Mümkünse “fatura” sayfasında “özel no” ile karşılığı olanların sarı vurgu renk, olmayanların ise kırmızı vurgu renge boyansa çok güzel olur.." demiştim eğer zor değilse bakarsanız sevinirim..
2-sonuç sayfasındaki veriler kod her çalıştığında temizlense iyi olur bazen eski verinin üstüne geliyor..
3-fatura sayfasında tarih yani A sütunu boşsa o veriyi karşılaştırmıyor..

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Sub ÖZEL_NO_AKTAR()
    Set SF = Sheets("fatura")
    Set ST = Sheets("telno")
    Set SS = Sheets("sonuc")
    SF.[A2:F65536].Interior.ColorIndex = xlNone
    SS.[A2:G65536].ClearContents
    SATIR = 2
    For X = 2 To SF.[D65536].End(3).Row
    Set BUL = ST.[C:F].Find(SF.Cells(X, 4), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    SF.Range("A" & X & ":F" & X).Interior.ColorIndex = 36
    SS.Range("A" & SATIR & ":F" & SATIR).Value = SF.Range("A" & X & ":F" & X).Value
    SS.Cells(SATIR, 7) = ST.Cells(BUL.Row, 2)
    SATIR = SATIR + 1
    Else
    SF.Range("A" & X & ":F" & X).Interior.ColorIndex = 38
    End If
    Next
    SS.Cells(SATIR, 4) = "GENEL TOPLAM"
    SS.Cells(SATIR, 5) = "=SUM(E2:E" & SATIR - 1 & ")"
    SS.Select
    Set SF = Nothing
    Set ST = Nothing
    Set SS = Nothing
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[osmanak]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Sub ÖZEL_NO_AKTAR()
    Set SF = Sheets("fatura")
    Set ST = Sheets("telno")
    Set SS = Sheets("sonuc")
    SF.[A2:F65536].Interior.ColorIndex = xlNone
    SS.[A2:G65536].ClearContents
    SATIR = 2
    For X = 2 To SF.[D65536].End(3).Row
    Set BUL = ST.[C:F].Find(SF.Cells(X, 4), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    SF.Range("A" & X & ":F" & X).Interior.ColorIndex = 36
    SS.Range("A" & SATIR & ":F" & SATIR).Value = SF.Range("A" & X & ":F" & X).Value
    SS.Cells(SATIR, 7) = ST.Cells(BUL.Row, 2)
    SATIR = SATIR + 1
    Else
    SF.Range("A" & X & ":F" & X).Interior.ColorIndex = 38
    End If
    Next
    SS.Cells(SATIR, 4) = "GENEL TOPLAM"
    SS.Cells(SATIR, 5) = "=SUM(E2:E" & SATIR - 1 & ")"
    SS.Select
    Set SF = Nothing
    Set ST = Nothing
    Set SS = Nothing
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

çok teşekkür ederim tam istediğim gibi çalışıyor...sağolun...