Question

我需要将1个工作表（Sheet1）与另一个类似的工作表（Sheet2）进行比较

Sheet2包含最新信息，需要将其传输到Sheet1。

然而，我遇到了几个问题：

Sheet1中有一些行不是Sheet2。
Sheet2中有些行不是Sheet1。这些需要附加到Sheet1的末尾
如果两个表格中都存在一行，则需要将行表2中的信息传输到Sheet1中的相应行

对于它的价值，它们具有相同数量的列，并且列标题完全相同。

我尝试使用字典对象来完成此操作，但仍然遇到各种各样的麻烦。

这是我到目前为止尝试过的代码：

Sub createDictionary()
    Dim dict1, dict2 As Object
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")

    Dim maxRows1, maxRows2 As Long
    Dim i, ii, j, k As Integer

    maxRows1 = Worksheets("Sheet1").Range("A65000").End(xlUp).Row

    For i = 2 To maxRows1

      Dim cell1 As String

      cell1 = Worksheets("Sheet1").cells(i, 2).Text & " " & Worksheets("Sheet1").cells(i, 11).Text

        If Not dict1.Exists(cell1) Then
            dict1.Add cell1, cell1
        End If

    Next i

    maxRows2 = Worksheets("Sheet2").Range("A65000").End(xlUp).Row

    For ii = 2 To maxRows2

        Dim cell2 As String

        cell2 = Worksheets("Sheet2").cells(ii, 11).Text

        If Not dict2.Exists(cell2) Then
            dict2.Add cell2, cell2
        End If

    Next ii

    Dim rngSearch1, rngFound1, rngSearch2, rngFound2 As Range

    For j = 2 To maxRows1

    Dim Sheet1Str, Sheet2Str As String
    Sheet1Str = Worksheets("Sheet1").cells(j, 2).Text & " " & Worksheets("Sheet1").cells(j, 11).Text
    Sheet2Str = Worksheets("Sheet2").cells(j, 11).Text


        If dict2.Exists(Sheet1Str) = False Then


        'ElseIf Not dict1.Exists(Sheet2) Then
        '
        '    Worksheets("Sheet2").Range("A" & j & ":" & "Z" & j).Copy
        '    Worksheets("Sheet1").Range("A" & maxRows1 + 1).Insert
        '    Worksheets("Sheet1").Range("A" & maxRows1 + 1).Interior.Color = RGB(255, 255, 0)
        '    Worksheets("Sheet1").Range("U" & maxRows1 + 1) = "INCH"
        '    Worksheets("Sheet1").Range("Q" & maxRows1 + 1) = "FPM"
        '    Worksheets("Sheet1").Range("S" & maxRows1 + 1) = "INCHES WIDE"

        '    Worksheets("Sheet2").Range("K" & j) = Replace(Worksheets("Sheet2").Range("K" & j), Worksheets("Sheet2").Range("B" & j), "")
        '    Worksheets("Sheet1").Range("K" & maxRows1 + 1) = Trim(Worksheets("Sheet2").Range("K" & j))

        Else
            For k = 3 To 6
            If Not k = 11 Then
                    If Not UCase(Worksheets("Sheet1").cells(j, k).Value) = UCase(Worksheets("Sheet2").cells(j, k).Value) Then
                         Worksheets("Sheet1").cells(j, k).Value = Worksheets("Sheet2").cells(j, k).Value
                    End If
            End If
            Next k

        End If

    Next j


End Sub

Answer 1

很酷的问题，上面的“排行顺序问题”非常适合使用Excel的内置Range.RemoveDuplicates方法。让我们进入它......

假设Sheet1如下所示：

sheet_1_start

让我们说Sheet2看起来像这样：

sheet_2_start

此处符合原始问题中描述的所有条件。即：

Sheet1上的行不在Sheet2上（例如，第2行）。这些将被单独留下。
Sheet2上的行不在Sheet1上（例如，第2行）。这些内容将添加到Sheet1。
除了单个更新外，Sheet2和Sheet1上的行相同。（例如，Sheet2上的第7行。）这些行将在Sheet1上更新。当然，您的情况会有所不同 - 可能会更新更多列，或者它们可能不像我的示例那样位于E列中 - 您需要在此处进行一些自定义。

以下评论很重的脚本会将数据从Sheet2复制到Sheet1，然后让Excel的内置Range.RemoveDuplicates方法删除E列中已更新的所有行该脚本还使用了几个方便的功能：LastRowNum和LastColNum。

Option Explicit
Sub MergeSheetTwoIntoSheetOne()

Dim Range1 As Range, Range2 As Range
Dim LastRow1 As Long, LastRow2 As Long, _
    LastCol As Long

'setup - set references up-front
LastRow2 = LastRowNum(Sheet2)
LastRow1 = LastRowNum(Sheet1)
LastCol = LastColNum(Sheet1) '<~ last col the same on both sheets

'setup - identify the data block on sheet 2
With Sheet2
    Set Range2 = .Range(.Cells(2, 1), .Cells(LastRow2, LastCol))
End With

'setup - identify the data block on sheet 1
With Sheet1
    Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
End With

'step 1 - move the data block on sheet 1 down the sheet
'         to allow room for the data block from sheet 2
Range1.Cut Destination:=Sheet1.Cells(LastRow2 + 1, 1)

'step 2 - move the data block from sheet 2 into the recently-
'         cleared space on sheet 1
Range2.Copy Destination:=Sheet1.Cells(2, 1)

'step 3 - find the NEW last row on sheet 1
LastRow1 = LastRowNum(Sheet1)

'step 4 - use excel's built-in duplicate removal to
'         kill all dupes on every column EXCEPT for those
'         that might have been updated on sheet 2...
'         in this example, Column E is where updates take place
With Sheet1
    Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
    Range1.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With

End Sub

'this handy function allows us to find the last row with a one-liner
Public Function LastRowNum(Sheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        LastRowNum = Sheet.Cells.Find(What:="*", _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
    Else
        LastRowNum = 1
    End If
End Function

'this handy function allows us to find the last column with a one-liner
Public Function LastColNum(Sheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        LastColNum = Sheet.Cells.Find(What:="*", _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious).Column
    Else
        LastColNum = 1
    End If
End Function

运行此脚本会产生以下结果：

end

比较和更新2个不同的工作表

1 个答案: