如何使用 vba 匹配列并计算匹配项答案

【问题标题】：How to match columns and count the matches using vba如何使用 vba 匹配列并计算匹配项
【发布时间】：2021-02-03 16:30:27
【问题描述】：

我正在处理一个我有两张纸的场景。 Sheet1 是我正在创建的主表和 sheet2。

Sheet1 的 Column1 是 Object，它也有重复的对象。所以，我所做的是创建了一个宏，它将生成唯一的对象并将其粘贴到 sheet2 中。

现在，从 Sheet2 开始，每个对象都应该与 Sheet1 的 column1 匹配，并且根据匹配结果，它还应该计算 sheet1 中其他列到 sheet2 的相应条目。

下面是我两张床单的截图

Sheet1

Sheet2

这是我的宏代码，它将首先将唯一对象从 sheet1 复制并粘贴到 sheet2 Column1。

Sub UniqueObj()
Dim Sh1 As Worksheet
    Dim Rng As Range
    Dim Sh2 As Worksheet
    Set Sh1 = Worksheets("Sheet1")
    Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
    Set Sh2 = Worksheets("Sheet1")
    Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
    Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
    
End Sub

但是，我无法从那里继续前进。我很新，任何帮助都会非常有用。

谢谢

【问题讨论】：

很抱歉没有坚持使用 VBA，但既然您使用 Excel，为什么不使用 PowerQuery 并运行合并操作从匹配项中检索您想要的任何数据？
此工作表还有其他宏。所以为了保持用户的一致性和易用性
您仍然可以清楚地描述 PQ 上的数据操作，并在最坏的情况下通过 VBA xD 刷新它。不管 PQ，我建议将 Sheet1 中的数据保留为表对象，因此您可以使用专用方法访问数据，然后可以轻松地对“对象”列进行重复数据删除。稍后您可以在 sheet2 上使用 countifs 公式，并使用 VBA 将公式交换为值。

标签： excel vba

【解决方案1】：

如果我正确理解您想要什么，您只是在计算 Sheet1 中相应列中的值不为空的匹配列？如果是这样，这应该可以解决问题。

Option Explicit

Sub GetStuffFromSheet1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim x As Long

'turn on error handling
On Error GoTo error_handler

Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")

'determine last row with data in sheet 1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row

'determine last row with data in sheet 2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

'define columns in sheet 1
Const objCol1 As Long = 1
Const rProdCol1 As Long = 3
Const keysCol1 As Long = 4
Const addKeysCol1 As Long = 5

'define columns in sheet 2
Const objCol2 As Long = 1
Const rProdCol2 As Long = 2
Const keysCol2 As Long = 3
Const addKeysCol2 As Long = 4

'turn off screen updating + calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'loop through all rows of sheet 2
For x = 2 To lastRow2
    
    'formula counts # of cells with matching obj where value isn't blank
    ws2.Cells(x, rProdCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(rProdCol1), "<>" & "")
    ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" & "")
    ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" & "")
    
Next x

'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Exit Sub

error_handler:

'display error message
MsgBox "Error # " & Err.Number & " - " & Err.Description, vbCritical, "Error"

'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Exit Sub

End Sub

【讨论】：

【解决方案2】：

如果非 VBA 解决方案适合您，您可以使用数据透视表恢复数据，将字段 Object 放入行部分，将其余字段放入值部分（选择 Count）

这将返回您正在寻找的确切输出。易于更新和创建。

如果您需要 VBA 解决方案，因为您的设计是表格并且您正在计算值，您可以使用 CONSOLIDATE：

Consolidate data in multiple worksheets

'change K1 with cell where to paste data.
Range("K1").Consolidate Range("A1").CurrentRegion.Address(True, True, xlR1C1, True), xlCount, True, True, False

'we delete column relation type and column value. This columns depends on where you paste data, in this case, K1
Range("L:L,P:P").Delete Shift:=xlToLeft

执行代码后我得到这个：

希望对你有帮助

【讨论】：