1

複数の行を読み取り、各行のエントリの合計をエントリとする新しい行を作成する方法を探しています。私は .Find のコンテキストでこれを行っています。ここでは、33405 x 16 の大きなスプレッドシートがあり、VBA が strSearch() 配列の文字列を含むすべての行を見つけたら、新しい行の合計を作成したいと考えています。見つかったすべての行の各セル。

現在、一度に各セルにアクセスする方法がありますが、非常に時間がかかります (15 分)。行全体を一度に操作できるようにしたいと思います。おそらく、その線に沿った何か

  1. strSearch() で最初の要素の最初のインスタンスを検索し、行全体にコピーします
  2. この行を一番下の新しい行にコピーします
  3. そこから、str(Search) で 2 番目の要素の最初のインスタンスを見つけ、行全体をコピーします。
  4. 最後の行をそれ自体とこの新しい行の合計に置き換えます
  5. strSearch() の最後の要素まで繰り返す
  6. この場所から、strSearch() の最初の要素からプロセスを繰り返し、範囲の最後まで続けます。

私が持っている現在のコードは以下のとおりです。これが行うことは、strSearch() で最初の文字列のすべてのインスタンスの行番号を見つけ、それらの行を一番下にコピーすることです。次に、strSearch() で文字列 2 のすべてのインスタンスの行番号を見つけ、それらの行を一番下の行にセルごとに追加します (したがって、スプレッドシートの最後の行は、最後の行に対応する行の項目ごとの合計になります)。 string1 と string2 のインスタンス)。スプレッドシートの各行の最初の 5 つのセルは場所を指定する文字列で、行の残りのセルは 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全体を約1週間検索して、同様の質問/回答を見つけようとしましたが、役に立ちませんでした。

4

1 に答える 1