#excel #vba
#excel #vba
Вопрос:
Я работаю над одним сценарием, в котором у меня есть два листа. Лист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. Извините, что не придерживаюсь VBA, но поскольку вы работаете с Excel, почему бы не использовать PowerQuery и не запускать операции слияния для извлечения любых данных, которые вы хотите, из сопоставленных элементов?
2. на этом листе есть и другие макросы. Таким образом, чтобы поддерживать единообразие и удобство для пользователей
3. Вы все равно могли бы четко описать операции с данными в PQ и в худшем случае обновить его через VBA xD. Независимо от PQ я бы посоветовал хранить данные в Sheet1 как объект таблицы, поэтому вы можете получить доступ к данным с помощью специальных методов, а затем легко дедуплицировать столбец «Объект». Позже вы могли бы использовать формулы countifs на листе 2 и просто заменять формулы значениями с помощью VBA.
Ответ №1:
Если я правильно понимаю, что вы хотите, вы просто подсчитываете совпадающие столбцы из листа 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
Ответ №2:
В случае, если вам подходит решение, отличное от 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
После выполнения кода я получаю следующее:
Надеюсь, это поможет