Копирование из динамического диапазона с использованием цикла и вставка в динамический диапазон с использованием цикла

Question

Я хочу написать оператор If, чтобы скопировать всю строку;если ячейка в определенном столбце содержит идентификатор, вставьте всю строку в рабочую таблицу (имя рабочей таблицы равно идентификатору) в следующей доступной пустой строке, иначе найдите в следующей строке идентификатор.

У меня есть около 40 уникальных идентификаторов, которым нужны строки, чтобы попасть в 40 уникальных таблиц.В идеале я хотел бы создать один цикл, который просматривает матрицу идентификаторов и респектабельные таблицы, в которые должны быть вставлены строки (с этими идентификаторами).

Мой код:

Worksheets("XL Detail").Activate
Dim IR As Worksheet, r As Long
Set IR = Worksheets("XL Detail")
Dim AS1 As Worksheet, a1 As Long
Set AS1 = Worksheets("12102")
mRow = AS1.Cells(Rows.Count, 1).End(xlUp).Row
nRow = mRow + 1
For r = 2 To IR.Range("a1048576").End(xlUp).Row Step 1
   If IR.Range("C" & r).Value = "12102" Then IR.Range("C" & r).EntireRow.Copy
    AS1.Cells(nRow, 1).PasteSpecial
    nRow = nRow + 1
    Next r

Answer 1

Может быть, что-то подобное тоже будет работать.(Это может быть немного быстрее, чем циклически проходить по каждой строке.)

Если вы попробуете это и получите слишком много окон сообщений (из-за несуществующих листов), возможно, просто добавьте некоторую другую логику в Elseветвь оператора If.

Option Explicit

Private Sub CopyPasteToCorrespondingSheets()

    With ThisWorkbook.Worksheets("XL Detail")
        If .AutoFilterMode Then .Cells.AutoFilter ' Do this here before lastRow

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        Dim rangeContainingIdentifiers As Range
        Set rangeContainingIdentifiers = .Range("C2:C" & lastRow)
    End With

    Dim uniqueIdentifers As Collection
    Set uniqueIdentifers = UniqueValuesInRange(rangeContainingIdentifiers)

    Dim uniqueSheetName As Variant
    Dim sheetToPasteTo As Worksheet

    ' Not sure if there is a better way to include the row immediately above the first row of a particular range
    With rangeContainingIdentifiers.Offset(-1, 0).Resize(1 + rangeContainingIdentifiers.Rows.Count, 1)
        For Each uniqueSheetName In uniqueIdentifers
            On Error Resume Next
            Set sheetToPasteTo = ThisWorkbook.Worksheets(uniqueSheetName)
            On Error GoTo 0

            If Not (sheetToPasteTo Is Nothing) Then
                lastRow = sheetToPasteTo.Cells(sheetToPasteTo.Rows.Count, "C").End(xlUp).Row

                .AutoFilter Field:=1, Criteria1:=uniqueSheetName
                rangeContainingIdentifiers.SpecialCells(xlCellTypeVisible).EntireRow.Copy
                sheetToPasteTo.Cells(lastRow + 1, "C").EntireRow.PasteSpecial xlPasteValuesAndNumberFormats

                Set sheetToPasteTo = Nothing
            Else
                MsgBox ("No sheet named '" & uniqueSheetName & "' was found. Code will continue running (for rest of unique identifiers).")
            End If
        Next uniqueSheetName

        .AutoFilter
    End With

    Application.CutCopyMode = False

End Sub

Private Function UniqueValuesInRange(ByRef rangeToCheck As Range, Optional rowsToSkip As Long = 0) As Collection
    Dim inputArray() As Variant
    inputArray = rangeToCheck.Value2

    Dim outputCollection As Collection ' Will not differentiate between "10" and 10
    Set outputCollection = New Collection

    Dim rowIndex As Long
    Dim collectionKey As String

    For rowIndex = (LBound(inputArray, 1) + rowsToSkip) To UBound(inputArray, 1)
        collectionKey = CStr(inputArray(rowIndex, 1))

        ' Only look at first column.
        On Error Resume Next
        outputCollection.Add Item:=collectionKey, Key:=collectionKey
        On Error GoTo 0
    Next rowIndex

    Set UniqueValuesInRange = outputCollection
End Function

Answer 2

Проверено

Это будет циклически проходить по вашим листам, а затем циклически проходить по Column C на вашем листе XL Detail, захватывая все строки, имеющие значение, равное имени текущего листа

Option Explicit

Sub Master_Loop()

Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("XL Detail")
Dim LR As Long, ws As Worksheet, xCell As Range, CopyMe As Range
Dim x As Long

LR = ms.Range("C" & ms.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
    For Each ws In Worksheets

        If ws.Name <> ms.Name Then
            For Each xCell In ms.Range("C2:C" & LR)
                If xCell = ws.Name Then
                    If Not CopyMe Is Nothing Then
                        Set CopyMe = Union(CopyMe, xCell)
                    Else
                        Set CopyMe = xCell
                    End If
                End If
            Next xCell
        End If

        If Not CopyMe Is Nothing Then
            x = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row
            CopyMe.EntireRow.Copy ws.Range("A" & x)
            Set CopyMe = Nothing
        End If

    Next ws
Application.ScreenUpdating = True

End Sub