VBA查找值并将其放在特定列中

Question

希望你能在这里帮助我。我每周都有一项重复性任务，我可以通过 Excel 公式每次都以相同的方式完成，但我正在寻找一种更自动化的方式来解决这个问题。



我想要实现的是设置一个动态范围，它将查找多个关键字，例如在本例中为“OA”和“SNC”，如果匹配，它将分别返回 G 和 H 列中的值。同时它必须跳过空白行。解决此问题的最佳方法是什么？

我认为它不应该太难，但我无法弄清楚。



如上图所示，我想在行级别的指定列(“G”和“H”)中合并每个类别(OA 和 SNC)的费用。

Answer 1

我的任务方法
过程查找数据范围，遍历它的值，将唯一值添加到字典中，并为特定行添加总和，然后加载所有这些值以及每行的总和。

Option Explicit
Sub CountStuff()
    Dim wb As Workbook, ws As Worksheet
    Dim lColumn As Long, lRow As Long, lColTotal As Long
    Dim i As Long, j As Long
    Dim rngData As Range, iCell As Range
    Dim dictVal As Object
    Dim vArr(), vArrSub(), vArrEmpt()
    
    'Your workbook
    Set wb = ThisWorkbook
    'Set wb = Workbooks("Workbook1")
    
    'Your worksheet
    Set ws = ActiveSheet
    'Set ws = wb.Worksheets("Sheet1")
    
    'Number of the first data range column
    lColumn = ws.Rows(1).Find("1", , xlValues, xlWhole).Column
    'Number of the last row of data range
    lRow = ws.Cells(ws.Rows.Count, lColumn).End(xlUp).Row
    'Total number of data range columns
    lColTotal = ws.Cells(1, lColumn).End(xlToRight).Column - lColumn + 1
    'Data range itself
    Set rngData = ws.Cells(1, lColumn).Resize(lRow, lColTotal)
    'Creating a dictionary
    Set dictVal = CreateObject("Scripting.Dictionary")
    'Data values -> array
    vArr = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, _
                                       rngData.Columns.Count).Value
    'Empty array
    ReDim vArrEmpt(1 To UBound(vArr, 1))
    'Loop through all values
    For i = LBound(vArr, 1) To UBound(vArr, 1)
        For j = LBound(vArr, 2) To UBound(vArr, 2)
            'Value is not numeric and is not in dictionary
            If Not IsNumeric(vArr(i, j)) And _
                    Not dictVal.Exists(vArr(i, j)) Then
                'Add value to dictionary
                dictVal.Add vArr(i, j), vArrEmpt
                vArrSub = dictVal(vArr(i, j))
                vArrSub(i) = vArr(i, j - 1)
                dictVal(vArr(i, j)) = vArrSub
            'Value is not numeric but already exists
            ElseIf dictVal.Exists(vArr(i, j)) Then
                vArrSub = dictVal(vArr(i, j))
                vArrSub(i) = vArrSub(i) + vArr(i, j - 1)
                dictVal(vArr(i, j)) = vArrSub
            End If
        Next j
    Next i
    'Define new range for results
    Set rngData = ws.Cells(1, lColumn + lColTotal - 1). _
        Offset(0, 2).Resize(1, dictVal.Count)
    'Load results
    rngData.Value = dictVal.Keys
    For Each iCell In rngData.Cells
        iCell.Offset(1, 0).Resize(lRow - 1).Value _
            = Application.Transpose(dictVal(iCell.Value))
    Next
End Sub