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

已测试

这将遍历您的工作表，然后遍历工作表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

Answer 2

也许类似的事情也会起作用。（这可能比遍历每一行要快一些。）

如果尝试这样做，并且收到太多的消息框（由于不存在工作表），也许只需在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

使用循环从动态范围复制并使用循环粘贴到动态范围

2 个答案:

已测试