Question

我遇到了下面提到的代码，我想要做的是从工作表X2中获取Range("C4:C" & LastRow)的值，每次都会更改，并将每个值与所有打开的工作簿名称进行比较。如果找到匹配，则在工作表X1的A列中搜索该值并复制所有这些行。

最终目标是将这些行粘贴到具有相同值的打开的工作簿中。例如：范围C4具有TW00，则代码将搜索名称为“TW00.xlsx”的工作簿，并复制工作表X1中的所有行，这些行在名为TW00.xlsx的工作表中的A列中具有TW00值。

Dim BookNames()
ReDim BookNames(Windows.Count)
n = 1

For n = 1 To Windows.Count
    BookNames(n) = Workbooks(n).Name
    If Workbooks(n).Name = Workbooks("A.xlsx").Worksheets("X2").Range("C4:C" & LastRow).Value Then
        Set Rng = Workbooks("A.xlsx").Worksheets("X1").Range("A2:A50000")
        For Each c In Rng.Cells
            If c.Value = Workbooks("A.xlsx").Worksheets("X2").Range("C4").Value Then
                If Not CopyRng Is Nothing Then
                    Set CopyRng = Application.Union(CopyRng, 
                    Workbooks("A.xlsx").Worksheets("X1").Rows(c))
                Else
                    Set CopyRng = Workbooks("A.xlsx").Worksheets("X1").Rows(c)
                End If
            End If
        Next c

        CopyRng.Copy
        Workbooks(n).Activate
        Worksheets.Add
        ActiveSheet.Name = "X1"
        ActiveSheet.Paste

    End If
Next n

Answer 1

该代码可以帮到你吗？

Sub test()
Dim lastRow As Long
dim sheetName as string
Dim sourceDataSheet As worksheet
Dim sourceSheetsName as worksheet
dim targetDataSheet as worksheet
Dim wkb As Variant

set sourceDataSheet = ActiveWorkbook.Worksheets("X2")
set sourceSheetsName  = ActiveWorkbook.Worksheets("X1")

With sourceSheetsName  
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    sheetName = .Cells(lastRow, "A")
        For Each wkb In Application.Workbooks
            If wkb.Name <> .Name And wkb.Name = sheetName Then
                set targetDataSheet = wkb.Worksheets.Add
                with sourceDataSheet
                    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                    for i = 1 to lastRow
                        if .Cells(i, "A").Value = sheetName then
                            .Cells(i, "A").EntireRow.Copy
                            targetDataSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                        end if
                    next i
                end with
            End If
        Next wkb
End With
End Sub

用于在打开的工作簿中粘贴值的vba代码，该工作簿具有与范围值类似的名称

1 个答案: