Soru VBA ile Bir Excel Sayfasındaki Bir Listeyi Başka Bir Excel Dosyasındaki bir sayfadaki listenin doğruluğunu test etmek

[ormancı421]

Merhaba Arkadaşlar Bir Excel Dosyamız var ve Bu dosya Ana Dosya. Bu dosyanın bir sayfasında Iban No, Ad Soyad ,ve TC No Listem var.
Başka Bir Excel Dosyasının bir sayfasında aynı sütunlara sahip bir liste var Vba ile Önce Dosya yolunu bulup Sonra Ana dosyadaki liste ile ikinci Excel dosyasındaki Listeyi satır satır kontrol ettirip hata olup olmadığını teyit ettirmek istiyorum yardımcı olabilirmisiniz Teşekkürler

 

[dost]

merhaba,

Aşağıdaki kodları kendinize uyarlarsınız.

Global myPath1
Global myWb2 As Workbook

Sub Compare2WorkSheets(ws1 As Worksheet, ws2 As Worksheet)

Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Dim RepWs, sh As Worksheet

For Each sh In myWb2.Sheets
     If sh.Name = "Report" Then
         Application.DisplayAlerts = False
         myWb2.Worksheets.Item(sh.Name).Delete
         Application.DisplayAlerts = True
     End If
Next sh

myWb2.Sheets.Add(After:=ActiveWorkbook.Sheets(myWb2.Sheets.Count)).Name = "Report"
Set RepWs = myWb2.Sheets("Report")

With ws1.UsedRange
    ws1row = .Rows.Count
    ws1col = .Columns.Count
End With

With ws2.UsedRange
    ws2row = .Rows.Count
    ws2col = .Columns.Count
End With

maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
difference = 0

For col = 1 To maxcol
    For row = 1 To maxrow
        colval1 = ""
        colval2 = ""
        colval1 = ws1.Cells(row, col).Formula
        colval2 = ws2.Cells(row, col).Formula
        If colval1 <> colval2 Then
            difference = difference + 1
            RepWs.Cells(row, col).Formula = colval1 & " <> " & colval2
            RepWs.Cells(row, col).Interior.Color = 255
            RepWs.Cells(row, col).Font.ColorIndex = 2
            RepWs.Cells(row, col).Font.Bold = True
        End If
    Next row
Next col

Workbooks("Test1.xlsx").Close SaveChanges:=False

Columns("A:B").ColumnWidth = 25


Set RepWs = Nothing
MsgBox difference & " Hücre(ler) farklı veri içerir! ", vbInformation, "İki Sayfa Karşılaştırma"

End Sub

Sub Find_Diff()
Dim myWb1

myPath1 = "C:\Users\xxxxx\Documents\Test\"   'xxxxx işaretli alan kullanıcı adı yazılmalıdır
Set myWb1 = Workbooks.Open(myPath1 & "Test1.xlsx")
Set myWb2 = Workbooks("Test2.xlsm")
Compare2WorkSheets Workbooks("Test2.xlsm").Worksheets("Sheet1"), myWb1.Worksheets("Sheet1")

End Sub