Question

希望您可以在这里帮助我。我每周都有一个重复的任务，我可以通过Excel公式每次都执行相同的操作，但是我正在寻找一种更自动化的方法。

Data example

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

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

Expected results

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

Answer 1

我使用了一个简单的自定义函数，可能会用工作表公式来解决问题，但是可能会过大，但是鉴于您的范围可以在任一方向上变化...

Function altsum(r As Range, v As Variant) As Variant

Dim c As Long

For c = 2 To r.Columns.Count Step 2
    If r.Cells(c) = v Then altsum = altsum + r.Cells(c - 1)
Next c

If altsum = 0 Then altsum = vbNullString

End Function

下面的示例在F2中上下复制和公式化（或将其与另一段代码一起应用）。

Answer 2

我的工作方式

过程查找数据范围，遍历其值，将具有特定行总和的唯一值添加到字典中，然后将所有这些值以及每行总和加载。

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

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

2 个答案:

我的工作方式