Блог

У меня есть два файла Excel под названием «Файл1» и «Файл2», которые содержат по два столбца, каждый из которых называется человеком, Адрес, если имя человека совпадает в обоих случаях, то необходимо сравнить адрес этого конкретного имени человека в обоих случаях, и необходимо выделить различия. Может ли кто-нибудь помочь мне с кодом VBA для этого

Сравнение столбцов ( Match feat. Union )

• Предполагается, что обе книги открыты.
• Отрегулируйте значения в разделе константы и цвета в конце кода.
• Принцип источника/назначения здесь имеет мало смысла, но я предпочитаю его нумерации.
• В двух словах, он будет проходить по ячейкам источника, пытаясь сопоставить ячейку в пункте назначения и проверяя значения, расположенные рядом с нужными ячейками. Если они не равны, будут выделены оба.
• С не найденными значениями ячеек ничего не произойдет.

 Option Explicit

Sub highlightDifferences()
    
    Const swbName As String = "File1.xlsx"
    Const sName As String = "Sheet1"
    Const sCols As String = "A:B"
    Const sFirstRow As Long = 2
    
    Const dwbName As String = "File2.xlsx"
    Const dName As String = "Sheet2"
    Const dCols As String = "A:B"
    Const dFirstRow As Long = 2
    
    Dim sws As Worksheet: Set sws = Workbooks(swbName).Worksheets(sName)
    Dim srg As Range
    Dim sCell As Range
    With sws.Range(sCols).Rows(sFirstRow)
        Set sCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlValues, , , xlPrevious)
        If sCell Is Nothing Then Exit Sub
        Set srg = .Resize(sCell.Row - .Row   1)
    End With
    
    Dim dws As Worksheet: Set dws = Workbooks(dwbName).Worksheets(dName)
    Dim drg As Range:
    With dws.Range(dCols).Rows(dFirstRow)
        Dim dCell As Range
        Set dCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlValues, , , xlPrevious)
        If dCell Is Nothing Then Exit Sub
        Set drg = .Resize(dCell.Row - .Row   1)
    End With
    Dim drg1 As Range: Set drg1 = drg.Columns(1)
    Dim drg2 As Range: Set drg2 = drg.Columns(2)
    
    Dim srgDel As Range
    Dim drgDel As Range
    Dim cIndex As Variant
    
    For Each sCell In srg.Columns(1).Cells
        cIndex = Application.Match(sCell.Value, drg1, 0)
        If IsNumeric(cIndex) Then
            If sCell.Offset(, 1).Value <> drg2.Cells(cIndex).Value Then
                If srgDel Is Nothing Then
                    Set srgDel = sCell.Offset(, 1)
                    Set drgDel = drg2.Cells(cIndex)
                Else
                    Set srgDel = Union(srgDel, sCell.Offset(, 1))
                    Set drgDel = Union(drgDel, drg2.Cells(cIndex))
                End If
            End If
        End If
    Next sCell
    
    If Not srgDel Is Nothing Then
        srgDel.Interior.Color = vbYellow
        drgDel.Interior.Color = vbYellow
    End If

End Sub
 

 Sub CompareAddresses()
    Dim File1 As String
    Dim File2 As String
    Dim Sheetname1 As String
    Dim Sheetname2 As String
    Dim List1 As Variant
    Dim List2 As Variant
    Dim lastrow As Long
    Dim DiffAddress1() As Boolean
    Dim DiffAddress2() As Boolean
    Dim a As Long
    Dim b As Long
    Dim firstRow As Integer
    
    'Define Filepathes and Sheetnames
    File1 = "C:ExcelFile1.xlsx"
    File2 = "C:ExcelFile2.xlsx"
    Sheetname1 = "NameList"
    Sheetname2 = "NameList"
    firstRow = 2 'Row in which the data starts in both sheets
    
    'Open Files and load Data in Arrays
    Workbooks.Open Filename:=File1
    Windows(FilnameFromPath(File1)).activate
    Sheets(Sheetname1).Select
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    List1 = Range("A1:B" amp; lastrow)
    ReDim DiffAddress1(lastrow)

    Workbooks.Open Filename:=File2
    Windows(FilnameFromPath(File2)).activate
    Sheets(Sheetname2).Select
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    List2 = Range("A1:B" amp; lastrow)
    ReDim DiffAddress2(lastrow)
    
    'Check for Differences in Data
    For a = firstRow To UBound(List1, 1)
        For b = firstRow To UBound(List2, 1)
            If List1(a, 1) = List2(b, 1) Then
                If Not List1(a, 2) = List2(b, 2) Then
                    DiffAddress1(a) = True
                    DiffAddress2(b) = True
                End If
            End If
        Next b
    Next a
    
    'Mark Differences in Sheets with yellow background
    Windows(FilnameFromPath(File1)).activate
    Sheets(Sheetname1).Select
    For a = firstRow To UBound(List1, 1)
        If DiffAddress1(a) = True Then
            Range("B" amp; a).Interior.Color = 65535
        End If
    Next a
    Windows(FilnameFromPath(File2)).activate
    Sheets(Sheetname2).Select
    For a = firstRow To UBound(List2, 1)
        If DiffAddress2(a) = True Then
            Range("B" amp; a).Interior.Color = 65535
        End If
    Next a
    
End Sub


Public Function FilnameFromPath(FilePath As String) As String
    Dim int_Pos As Integer
    int_Pos = InStrRev(FilePath, "")
    FilnameFromPath = Mid(FilePath, int_Pos   1, Len(FilePath) - int_Pos)
End Function