Excel VBA 循環遍歷數據並復制行

Question

我有這個軟件，它被設置為遍歷數據集並根據特定頁面上的 searchTerm 拉出行。 我創建了兩個例程來從同一行中選擇兩組不同的數據，我希望將它們組合起來。

Public Sub addToMailchimpNameEmail()

    Dim datasheet As Worksheet
    Dim reportsheet As Worksheet
    Dim findthisstring As String
    Dim finalrow As Long
    Dim i As Long

    Set datasheet = ThisWorkbook.Worksheets("Registration Sheet") '<== I have set this up as sheet names not code names
    Set reportsheet = ThisWorkbook.Worksheets("Add to MailChimp")
    findthisstring = reportsheet.Range("H2").Value
    Worksheets("Registration Sheet").Activate

    With datasheet
        finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim unionRng As Range

        For i = 2 To finalrow
            If Cells(i, 15) = findthisstring Then '< in column O
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, .Range(.Cells(i, 2), .Cells(i, 4))) ' 'Select Cols B to D to copy
                Else
                    Set unionRng = .Range(.Cells(i, 2), .Cells(i, 4))
                End If
            End If
        Next i

    End With

    If Not unionRng Is Nothing Then
       If IsEmpty(reportsheet.Range("A150").End(xlUp)) And reportsheet.Range("A150").End(xlUp).Row = 1 Then
            unionRng.Copy reportsheet.Range("A1")
        Else
            unionRng.Copy reportsheet.Range("A150").End(xlUp).Offset(1, 0)
        End If
    End If
    Worksheets("Add to MailChimp").Activate
End Sub

這是第二個

Public Sub addToMailchimpCityState()

        Dim datasheet As Worksheet
        Dim reportsheet As Worksheet
        Dim findthisstring As String
        Dim finalrow As Long
        Dim i As Long

        Set datasheet = ThisWorkbook.Worksheets("Registration Sheet") '<== I have set this up as sheet names not code names
        Set reportsheet = ThisWorkbook.Worksheets("Add to MailChimp")
        findthisstring = reportsheet.Range("H2").Value
        Worksheets("Registration Sheet").Activate

        With datasheet
            finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row
            Dim unionRng As Range

            For i = 2 To finalrow
                If Cells(i, 15) = findthisstring Then '< in column O
                    If Not unionRng Is Nothing Then
                        Set unionRng = Union(unionRng, .Range(.Cells(i, 9), .Cells(i, 11))) ' 'Select Cols I to K to copy
                    Else
                        Set unionRng = .Range(.Cells(i, 9), .Cells(i, 11))
                    End If
                End If
            Next i

        End With

        If Not unionRng Is Nothing Then
           If IsEmpty(reportsheet.Range("A150").End(xlUp)) And reportsheet.Range("A150").End(xlUp).Row = 1 Then
                unionRng.Copy reportsheet.Range("A1")
            Else
                unionRng.Copy reportsheet.Range("A150").End(xlUp).Offset(1, 3)
            End If
        End If
        Worksheets("Add to MailChimp").Activate
    End Sub

唯一的區別是在Set unionRng部分中，我選擇了不同的列。 如果有人可以告訴我如何選擇 col 2,3,4,9,10,11，我不必做范圍。

謝謝！

Answer 1

以下是您的兩個程序的公平組合。 它未經測試。 如果它應該包含錯別字，請接受我的道歉。 我認為你將能夠糾正它們。

Public Sub addToMailchimpNameEmail()

    Dim Datasheet As Worksheet
    Dim Reportsheet As Worksheet
    Dim Cstart As Long, Cend As Long                ' columns
    Dim Rng As Range
    Dim UnionRng As Range
    Dim FindThisString As String
    Dim FinalRow As Long
    Dim R As Long
    Dim i As Integer

    Set Datasheet = ThisWorkbook.Worksheets("Registration Sheet") '<== R have set this up as sheet names not code names
    Set Reportsheet = ThisWorkbook.Worksheets("Add to MailChimp")
    FindThisString = Reportsheet.Range("H2").Value

    Cstart = 2                  ' set columns for first loop
    Cend = 4

    For i = 1 To 2              ' extract different data on each loop
        With Datasheet
            FinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            For R = 2 To FinalRow
                If Cells(R, 15) = FindThisString Then '< in column O
                    Set Rng = .Range(.Cells(R, Cstart), .Cells(R, Cend))
                    If UnionRng Is Nothing Then
                        Set UnionRng = Rng
                    Else
                        Set UnionRng = Union(UnionRng, Rng)
                    End If
                End If
            Next R
        End With

        If Not UnionRng Is Nothing Then         ' How can it ever be Nothing?
            With Reportsheet
                FinalRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                UnionRng.Copy Reportsheet.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
            End With
            Set UnionRng = Nothing
        End If

        ' change columns for next loop
        Cstart = 9
        Cend = 11
    Next i

    Worksheets("Add to MailChimp").Activate
End Sub

觀察列是如何在第一個循環之前設置並在該循環結束時重置以用於第二個循環。 該系統不能擴展到超過兩個循環。 如果您需要在第一個循環之前創建數組（ Dim Cstart As Variant ），例如Cstart = Array(2, 4, 17, 24)並且使用以下語法： Set Rng = .Range(.Cells(R, Cstart(i)), .Cells(R, Cend(i)))但請記住Array()創建一個從零開始的數組，因此您必須將循環定義為For i = 0 To Ubound(Cstart)