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

Question

I'm looking for a way to read in multiple rows and create a new row whose entries are the sums of the entries in each row. I'm doing this in the context of a .Find, where I have a large 33405 x 16 spreadsheet, and once VBA find all the rows containing any of the strings from my strSearch() array, I want to create a new row summing each cell across all the rows found.

Right now I have a way to do this that accesses each cell at a time, but it's very slow (15 minutes). I'd like to be able to manipulate whole rows at once. Perhaps something along the lines of

1. Find first instance of first element in strSearch(), copy in the entire row
2. Copy this row to new row at bottom
3. From there, find first instance of second element in str(Search), copy in entire row
4. Replace the last row with the sum of itself and this new row
5. Repeat until last element in strSearch()
6. From this spot, repeat the process from the first element in strSearch(), continuing until the bottom of the range.

The current code I have is below. What this does is find the row number of every instance of the first string in strSearch(), and copies those rows to the bottom. Then it finds the row number for every instance of string 2 in strSearch() and adds those rows to the rows at the bottom, cell by cell (so the last row in the spreadsheet is now the entrywise sum of the rows corresponding to the last instance of string1 and string2). The first five cells in each row of the spreadsheet are strings specifying locations, and then the remaining cells in an row are longs.

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

In an attempt to read and manipulate whole rows, I've messed around with collections, but this code doesn't work very well, and I don't know what to put in the Else (k <> 0) statement to get the results I want.

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

Sorry if this is vague, hopefully there's a faster way to do this! I'm fairly new to VBA, but I've searched all over google and stackoverflow for about a week to try to find a similar question/answer to no avail.

Answer 1

Let's try something easy.

Instead of create an array and use VBA you can use just formulas. Lets try something like this:

1. Create an extra column for each string in your array [Column 17, 18, 19 ...].
2. Add the formula: =ISERROR(IF(FIND(<STRING_VALUE>,<STRING_TO_SEARCH>),"X"),"")
3. To sum the value you can create a new table like this:

Example:

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>)