Excel VBA L oop через данные и копировать строки

Question

У меня есть это программное обеспечение, которое настроено на l oop через набор данных и вытягивает строки в соответствии с searchTerm на указанной странице c. Я создал две подпрограммы, чтобы выбрать два разных набора данных из одной строки, и я надеялся объединить их.

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, в которых я выбираю разные столбцы. Мне не нужно указывать диапазон, если кто-то может сказать мне, как выбрать кол 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

Обратите внимание, как столбцы устанавливаются перед первым l oop и сбрасываются в конце этого l oop, чтобы работать для второго l oop. Эта система не может быть расширена для работы более двух циклов. Если это необходимо, создайте массивы (Dim Cstart As Variant) перед первым l oop, например Cstart = Array(2, 4, 17, 24), и используйте следующий синтаксис: Set Rng = .Range(.Cells(R, Cstart(i)), .Cells(R, Cend(i))), но помните, что Array() создает массив с нулями, так что вы должны определите свой l oop как For i = 0 To Ubound(Cstart)