Блог

Я работаю над одним сценарием, в котором у меня есть два листа. Лист1 — это основной лист и лист2, которые я создаю.

Column1 листа 1 — это объект, который также имеет повторяющиеся объекты. Итак, что я сделал, я создал макрос, который создаст уникальные объекты и вставит его в лист2.

Теперь, начиная с листа 2, каждый из объектов должен быть сопоставлен с листом 1 column1 и, основываясь на результатах сопоставления, он также должен подсчитывать соответствующие записи из других столбцов листа 1 в лист2.

Ниже приведены снимки моих двух листов

Лист1

Лист2

вот мой код макроса, который сначала скопирует и вставит уникальные объекты из листа 1 в столбец листа 21.

 Sub UniqueObj()
Dim Sh1 As Worksheet
    Dim Rng As Range
    Dim Sh2 As Worksheet
    Set Sh1 = Worksheets("Sheet1")
    Set Rng = Sh1.Range("A1:A" amp; 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
  

Но я не могу двигаться дальше оттуда. Я довольно новичок, и любая помощь была бы очень полезной.

Спасибо

Если я правильно понимаю, что вы хотите, вы просто подсчитываете совпадающие столбцы из листа 1, где значение в соответствующем столбце не является пустым? Если это так, это должно сработать.

 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), "<>" amp; "")
    ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" amp; "")
    ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" amp; "")
    
Next x

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

Exit Sub

error_handler:

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

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

Exit Sub

End Sub
  

В случае, если вам подходит решение, отличное от VBA, вы можете возобновить сбор данных с помощью сводной таблицы, перенести поле Object в раздел «Строки», а остальные поля — в раздел «значения» (выберите Count )

Это возвращает точный результат, который вы ищете. Легко обновлять и легко создавать.

Если вам нужно решение на VBA, поскольку ваш дизайн является табличным и вы подсчитываете значения, вы можете использовать КОНСОЛИДАЦИЮ:

Консолидация данных на нескольких рабочих листах

 '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
  

После выполнения кода я получаю следующее:

Надеюсь, это поможет