Question

来自上一篇文章的跟进问题：

VBA - Compare Column on Previous Report With New Report to Find New Entries

下面的解决方案将上周生成的报告与本周生成的报告进行比较，并在A列中找到两者之间的差异。然后，它将A列中的差异复制到A列的新工作表中。然而，范围略有变化，因为我需要从原始工作表中复制A列和B列中相邻单元格的差异。

例如：

A列包含用户ID，B列包含员工姓名

对用户ID进行比较，找到差异后，将该特定用户ID复制到新工作表。但是，我需要将用户ID以及员工姓名复制到新工作表，而不仅仅是用户ID。

我无法复制整行，因为其他列中的其他信息对于报告摘要不是必需的。

以下是Vityata提供的代码：

    Public Sub FindDifferences()

        Dim firstRange As Range
        Dim secondRange As Range

        Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
        Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
        Dim wks3 As Worksheet: Set wks3 = Worksheets(3)

        Set firstRange = wks1.UsedRange
        Set secondRange = wks2.UsedRange

        Dim myCell  As Range

        For Each myCell In firstRange
            If myCell <> secondRange.Range(myCell.Address) Then
                wks3.Range(myCell.Address) = myCell
            End If
        Next myCell

    End Sub

这是我目前的代码：

Public Sub FindDifferences()

    Dim firstRange As Range
    Dim secondRange As Range
    Dim myCell As Range

    Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet

    'Find Removed Wintel Servers
    Set wks1 = ActiveWorkbook.Sheets("sh1")
    Set wks2 = ActiveWorkbook.Sheets("sh2")
    Set wks3 = ActiveWorkbook.Sheets("sh3")

    Set firstRange = Range(wks1.Range("A1"), wks1.Range("A" & Rows.Count).End(xlUp))
    Set secondRange = Range(wks2.Range("A1"), wks2.Range("A" & Rows.Count).End(xlUp))

    For Each myCell In secondRange
        If WorksheetFunction.CountIf(firstRange, myCell) = 0 Then

            myCell.Copy
            wks3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            wks3.Cells(Rows.Count, 1).End(xlUp).PasteSpecial xlPasteFormats

        End If
    Next myCell

wks3.Range("A1").Select

End Sub

Answer 1

这可能不是最简单的方法，但它对我有用。如果您需要我解释不同的变量，请告诉我代码假定您在每张表的第一行都有标题。

Sub FindDifferences()

    Dim LastRow As Integer
    Dim LastRow2 As Integer
    Dim rng As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    Dim Counter As Integer
    Dim Counter2 As Integer


    Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
    Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
    Dim wks3 As Worksheet: Set wks3 = Worksheets(3)

        LastRow = wks1.Cells(Rows.Count, "A").End(xlUp).Row
        LastRow2 = wks2.Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = wks1.Range("A2")
        Set rng2 = wks1.Range("A2:B2")
        Set rng3 = wks2.Range("A2:A" & LastRow2)
        Set rng4 = wks3.Range("A2:B2")
        Counter = 2
        Counter2 = 2

    For x = 1 To LastRow

        Set ValueCheck = rng3.Find(rng.Value, LookIn:=xlValues)

        If ValueCheck Is Nothing Then
        rng2.Copy _
        Destination:=rng4
        Counter2 = Counter2 + 1
        End If

        Counter = Counter + 1
        Set rng = wks1.Range("A" & Counter)
        Set rng2 = wks1.Range("A" & Counter & ":B" & Counter)
        Set rng4 = wks3.Range("A" & Counter2 & ":B" & Counter2)

    Next x

End Sub

Answer 2

在您当前的代码中，您可以替换行

        myCell.Copy

有了这个：

.Range(myCell.Address & ":" & myCell.Offset(0,1).Address).Copy

我相信这样可行，我还没有正确测试，如果你收到错误让我知道我会试用它

VBA - 从A列和B列复制单元格并在新工作表中粘贴

2 个答案: