创建其条目是其他范围VBA的条目总和的新范围

Question

我正在寻找一种方法来读取多行并创建一个新行，其条目是每行中条目的总和。 我是在.Find的上下文中执行此操作的，这里有一个33405 x 16的大型电子表格，一旦VBA从strSearch（）数组中找到了包含任何字符串的所有行，我想创建一个新的行求和找到的所有行中的每个单元格。

现在，我有一种方法可以一次访问每个单元，但是非常慢（15分钟）。 我希望能够一次操纵整个行。 也许与

1. 在strSearch（）中查找第一个元素的第一个实例，并复制到整行中
2. 将此行复制到底部的新行
3. 从那里，在str（Search）中找到第二个元素的第一个实例，复制整行
4. 用自身和新行的总和替换最后一行
5. 重复直到strSearch（）中的最后一个元素
6. 从该位置开始，从strSearch（）的第一个元素开始重复该过程，直到该范围的底部。

我当前的代码如下。 这是在strSearch（）中找到第一个字符串的每个实例的行号，然后将这些行复制到底部。 然后，它在strSearch（）中找到字符串2的每个实例的行号，并将这些行逐个单元地添加到底部的行中（因此电子表格中的最后一行现在是与最后一个行相对应的行的逐项求和string1和string2的实例）。 电子表格每行中的前五个单元格是指定位置的字符串，然后一行中的其余单元格为long。

Private Function Add_Industries(sheetName As String, strSearch() As Variant, yearsNaicsData As Integer, newIndustry As Long)

Application.ScreenUpdating = False

Dim i As Integer, _
    j As Integer
Dim rngSearch As range
Dim firstAddress As String

Worksheets(sheetName).Activate
With Worksheets(sheetName).range("D:D")
    For k = 0 To UBound(strSearch)
    j = 0
    Set rngSearch = .Find(strSearch(k), .Cells(1), xlValues, xlWhole)                        
    If Not rngSearch Is Nothing Then
        firstAddress = rngSearch.Address
        Do
            If k = 0 Then                                                           'Add the first listings
                Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) = Cells(rngSearch.Cells.Row, 1)
                Cells(ActiveSheet.UsedRange.Rows.Count, 2) = Cells(rngSearch.Cells.Row, 2)
                Cells(ActiveSheet.UsedRange.Rows.Count, 3) = Cells(rngSearch.Cells.Row, 3)
                Cells(ActiveSheet.UsedRange.Rows.Count, 4) = newIndustry
                Cells(ActiveSheet.UsedRange.Rows.Count, 5) = Cells(rngSearch.Cells.Row, 5)
                For i = 6 To 6 + yearsNaicsData - 1
                    Cells(ActiveSheet.UsedRange.Rows.Count, i) = Cells(rngSearch.Cells.Row, i)
                Next
            Else                                                                    'Sum up the rest of the listings
                For i = 6 To 6 + yearsNaicsData - 1
                    Cells(ActiveSheet.UsedRange.Rows.Count - (254 - j), i) = Cells(ActiveSheet.UsedRange.Rows.Count - (254 - j), i) + Cells(rngSearch.Cells.Row, i)
                Next
                j = j + 1
            End If

            Set rngSearch = .FindNext(rngSearch)                                    'Find the next instance
        Loop While Not rngSearch Is Nothing And rngSearch.Address <> firstAddress
    End If
Next
End With

为了读取和操作整个行，我弄乱了集合，但是这段代码不能很好地工作，而且我不知道在Else（k <> 0）语句中放入什么来获取我想要的结果。

Private Function Add_Industries2(sheetName As String, strSearch() As Variant, yearsNaicsData As Integer, newIndustry As Long)

Application.ScreenUpdating = False

Dim i As Integer, _
    j As Integer, _
    k As Integer
Dim rngSearch As range
Dim cl As Collection
Dim buf_in() As Variant
Dim buf_out() As Variant
Dim val As Variant
Dim firstAddress As String

Worksheets(sheetName).Activate
With Worksheets(sheetName).range("D:D")

k = 0
Set rngSearch = .Find(strSearch(k), .Cells(1), xlValues, xlWhole)
If Not rngSearch Is Nothing Then
    firstAddress = rngSearch.Address
    Set cl = New Collection
    Do
        For k = 0 To UBound(strSearch)
            Set buf_in = Nothing
            buf_in = Rows(rngSearch.Row).Value
                If k = 0 Then
                    For Each val In buf_in
                        cl.Add val
                    Next
                Else
                    'Somehow add the new values from buff_in to the values in the collection?
                End If
            ReDim buf_out(1 To 1, 1 To cl.Count)

            Rows(ActiveSheet.UsedRange.Rows.Count + 1).Resize(1, cl.Count).Value = buf_out
            Cells(ActiveSheet.UsedRange.Rows.Count, 4) = newIndustry

            If k + 1 <= UBound(strSearch) Then
                Set rngSearch = .Find(strSearch(k + 1), .Cells(rngSearch.Cells.Row), xlValues, xlWhole)
            Else
                Set rngSearch = .Find(strSearch(0), .Cells(rngSearch.Cells.Row), xlValues, xlWhole)
                k = 0
            End If
        Next
    Loop While Not rngSearch Is Nothing And rngSearch.Address <> firstAddress
End If
End With
End Function

抱歉，如果不清楚，希望有更快的方法！ 我对VBA还是很陌生，但是我已经在整个Google和stackoverflow上搜索了大约一周的时间，试图找到一个类似的问题/答案无济于事。

Answer 1

让我们尝试一些简单的事情。

除了创建数组并使用VBA，您还可以仅使用公式。 让我们尝试这样的事情：

1. 为数组中的每个字符串创建一个额外的列[Column 17，18，19 ...]。
2. 添加公式： =ISERROR(IF(FIND(<STRING_VALUE>,<STRING_TO_SEARCH>),"X"),"")
3. 要对值求和，可以创建一个新表，如下所示：

例：

Column 1                Column 2
<STRING_VALUE_1>        =SUMIF(Columns(17),"X",<Column_To_SUM>)
<STRING_VALUE_2>        =SUMIF(Columns(18),"X",<Column_To_SUM>)
<STRING_VALUE_3>        =SUMIF(Columns(19),"X",<Column_To_SUM>)