将 A 列与 B 列和 B 列与 A 列进行比较，并将丢失的整行和添加的整行分别复制到新工作表

Question

我正在尝试找出解决这个问题的最佳方法，但我有点头晕，我不确定我是否应该使用 For Each Cell 或 Arrays 或 Collections 进行一些比较并将整行复制到新的 sheets。我想使用 Arrays 但我的代码只使用列的值但是我必须返回并重新循环列以找到“缺失值”并复制整行似乎打败了部分使用数组的要点 (speed/efficiency).

我正在寻找解决此问题的最佳方法的建议，但我也会 post 我的数组代码。

首先，示例数据：

工作表 1：

工作表 2：

想法是 Sheet1 是昨天的报告，sheet2 是今天的报告。

我的目标是再增加两个 sheet（或一个组合 sheet，但这似乎没有必要，因为我需要分别对每个结果 sheet 搜索结果进行总计算合计其中一列，但不是 A 列中的值）

添加的项目：

A6 AV6

删除的项目：

A5 AV5

所以基本上它是在比较 sheet2 和 sheet1 列 A.

中找到删除了哪些项目以及添加了哪些项目

到目前为止，我能够得到那部分，没有行值，我真的很想知道我是否正确地攻击了它。

IE：这会得到 missing/added 项。现在我需要为每个 sheet 中的值获取整行，但我不确定代码是如何开始看起来又长又重复的。

Public Function RangeToArray(Rng As Range) As Variant
    Dim i As Long, r As Range
    ReDim arr(1 To Rng.Count)

    i = 1
    For Each r In Rng
        arr(i) = r.Value
        i = i + 1
     Next r

    RangeToArray = arr
End Function
Public Sub Compare_Columns_A_and_B_with_Arrays()

 Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, Missing As Worksheet, Added As Worksheet
 Set wb = ActiveWorkbook
 Set wsA = wb.Worksheets("Sheet1")
 Set wsB = wb.Worksheets("Sheet2")

 Set Missing = wb.Worksheets("Missing")
 Set Added = wb.Worksheets("Added")

Dim lRowA As Long
 lRowA = wsA.Cells(Rows.Count, 1).End(xlUp).Row
 Dim sourceArray As Variant, srcrng As Range
 Set srcrng = wsA.Range("A1:A" & lRowA)
 sourceArray = RangeToArray(srcrng)

Dim lRowB As Long
 lRowB = wsB.Cells(Rows.Count, 2).End(xlUp).Row
 Dim verifyArray As Variant, verifyrng As Range
 Set verifyrng = wsB.Range("A1:A" & lRowB)
 verifyArray = RangeToArray(verifyrng)



For Each arrval In sourceArray
 IsInArray = (UBound(Filter(verifyArray, arrval)) > -1)
 If IsInArray = False Then
  'Debug.Print arrval
  Dim lRowMissing As Long
  lRowMissing = Missing.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
  Missing.Range("A" & lRowMissing).Value = arrval
 End If
Next arrval

For Each arrval In verifyArray
 IsInArray = (UBound(Filter(sourceArray, arrval)) > -1)
 If IsInArray = False Then
  'Debug.Print arrval
  Dim lRowAdded As Long
  lRowAdded = Added.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
  Added.Range("A" & lRowAdded).Value = arrval
 End If
Next arrval


End Sub

Answer 1

假设您想实现这样的目标：

在Sheet1和Sheet2中有headers（在我的例子中我使用了Header 1和Header 2。

结果sheet:

Yesterday 列包含有关 Sheet1 中 A(x) 数据计数的信息。
Today 列包含有关 Sheet2 中 A(x) 数据计数的信息。

我使用了以下代码：

Option Explicit

Sub CompareData()
    Dim wbk As Workbook
    Dim wshYesterday As Worksheet, wshToday As Worksheet, wshResult As Worksheet
    Dim i As Integer, j As Integer, k As Integer
    
    On Error Resume Next
    Set wbk = ThisWorkbook
    Set wshResult = wbk.Worksheets("Result")
    
    On Error GoTo Err_CompareData

    If Not wshResult Is Nothing Then
        Application.DisplayAlerts = False
        wbk.Worksheets("Result").Delete
        Application.DisplayAlerts = True
    End If
    Set wshYesterday = wbk.Worksheets("Sheet1")
    Set wshToday = wbk.Worksheets("Sheet2")
    Set wshResult = wbk.Worksheets.Add(After:=wshToday)
    wshResult.Name = "Result"
    wshResult.Range("A1") = "Header 1"
    wshResult.Range("B1") = "Header 2"
    wshResult.Range("C1") = "Yesterday"
    wshResult.Range("D1") = "Today"
    'find last entry in yesterdays data
    i = wshYesterday.Range("A" & wshYesterday.Rows.Count).End(xlUp).Row
    j = 2
    'copy into result sheet
    wshYesterday.Range("A2:B" & i).Copy wshResult.Range("A" & j)
    j = j + i - 1
    'find last entry in todays data and copy into result sheet
    i = wshToday.Range("A" & wshToday.Rows.Count).End(xlUp).Row
    wshToday.Range("A2:B" & i).Copy wshResult.Range("A" & j)
    'remove duplicates
    i = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
    wshResult.Range("A2:B" & i).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    j = 2
    i = wshResult.Range("A" & wshResult.Rows.Count).End(xlUp).Row
    Do While j <= i
        'count values stored in column #1 in yesterdays data
        k = Application.WorksheetFunction.CountIf(wshYesterday.UsedRange, wshResult.Range("A" & j))
        wshResult.Range("C" & j) = k
        'count todays data
        k = Application.WorksheetFunction.CountIf(wshToday.UsedRange, wshResult.Range("A" & j))
        wshResult.Range("D" & j) = k
        j = j + 1
    Loop

Exit_CompareData:
    On Error Resume Next
    Set wshYesterday = Nothing
    Set wshToday = Nothing
    Set wshResult = Nothing
    Set wbk = Nothing
    Exit Sub

Err_CompareData:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CompareData

End Sub

随时根据您的需要对其进行改进。

Answer 2

很难确切地知道您想要什么，但这里有一个 Power Query 解决方案（在 Excel 2010+ 中可用）创建一个 table 总结已删除的内容 and/or 添加。

我假设您的数据在 table 中，名为 Yesterday 和 Today。更改 Source = 行中的 table 名称以匹配您的真实数据。

M-Code

let
   //Read in the data tables
    Source = Excel.CurrentWorkbook(){[Name="Yesterday"]}[Content],
    Yesterday = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}}),
    Source2 = Excel.CurrentWorkbook(){[Name="Today"]}[Content],
    Today = Table.TransformColumnTypes(Source2,{{"Column1", type text}, {"Column2", type text}}),

    /*Using the appropriate JoinKind, create two different tables for
      itemsAdded and itemsRemove*/
        itemsAddedTBL = Table.NestedJoin(Today,"Column1",Yesterday,"Column1","TBL",JoinKind.LeftAnti),

        //Remove the unneeded TBL column
        itemsAdded = Table.RemoveColumns(itemsAddedTBL,"TBL"),

        //Add a column stating "Added"
        itemsAddedLBL = Table.AddColumn(itemsAdded,"Add/Remove", each "Added", type text),

        //Repeat the above for removed items
        itemsRemovedTBL = Table.NestedJoin(Yesterday,"Column1",Today,"Column1","TBL",JoinKind.LeftAnti),
        itemsRemoved = Table.RemoveColumns(itemsRemovedTBL,"TBL"),
        itemsRemovedLBL = Table.AddColumn(itemsRemoved, "Add/Remove", each "Removed",type text),

        //combine (append) the two tables into one
        comb = Table.Combine({itemsAddedLBL,itemsRemovedLBL})       

in
    comb

Answer 3

我实际上最终使用了@AceErno 的评论并使用 AutoFilter 提取了通过使用我原始问题中的代码比较数组找到的数据的 EntireRows。我对我的代码不太满意，但它确实有效，我可以稍后在我准备好时查看它。

将 A 列与 B 列和 B 列与 A 列进行比较，并将丢失的整行和添加的整行分别复制到新工作表

Comparing Column A to B and B to A and Copy Entire Row of Missing and Added to New Sheets Respectively

excel

vba

comparison