遍历 A 列并在不同工作簿的匹配表中复制值

Question

我有 2 个工作簿，其中工作簿 1 在 A 列中有一个名称列表，每个名称都有一行值。 工作簿 2 也有标有名称的工作表。其中一些名称与工作簿 1 的 A 列中的名称列表相同。

我想要实现的是检查 A 列中的名称是否与工作表名称匹配。如果是，我想复制该行中的值并将它们粘贴到工作簿 2 工作表中的特定单元格中。 如果 A 列中的每个名称在工作簿 2 中以相同的顺序都有相应的工作表，则我下面的代码可以正常工作。但是，我希望它能够跳过空格或跳过工作簿 2 中没有工作表的名称。所以我添加了一个 if 语句来查看是否可以解决问题，但这不起作用。我收到错误：“应用程序定义或对象定义错误”，突出显示 if 语句。

原来的工作代码没有 IF 语句。只要 A 列中没有空格并且每个名称都有相同顺序的匹配表，它就可以工作。

我也尝试在下一行添加错误恢复，但这只是停止触发错误代码。它将第一行复制/粘贴到正确的单元格中，但其余的则没有。

Sub Measures()

Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng, Rng2 As Range
Dim wb2 As Workbook
Dim cell As Range
Dim ws As Worksheet

Set wb1 = ThisWorkbook
Set wb2 = Workbooks("November Stream 1 v2.xlsm")
Set Sht = wb1.Worksheets("Summary")
Set Rng = Sht.Range("A7:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)

For Each cell In Rng
Set ws = wb2.Sheets(cell.Text)

If wb1.Sheets("Summary").Range("A" & i) = wb2.Sheet.Name Then

   Select Case ws.Range("A4").Value
        Case "green"  '
        ws.Range("B29").Value = cell.Offset(0, 1).Value
        ws.Range("B33").Value = cell.Offset(0, 2).Value
        ws.Range("B37").Value = cell.Offset(0, 3).Value
        ws.Range("B40").Value = cell.Offset(0, 4).Value
        ws.Range("B44").Value = cell.Offset(0, 5).Value
        
        Case "red"
        ws.Range("B47").Value = cell.Offset(0, 6).Value
        ws.Range("B51").Value = cell.Offset(0, 7).Value
        ws.Range("B54").Value = cell.Offset(0, 8).Value
        ws.Range("B60").Value = cell.Offset(0, 9).Value
        ws.Range("B65").Value = cell.Offset(0, 11).Value
        
        Case "blue"
        ws.Range("B68").Value = cell.Offset(0, 12).Value
        ws.Range("B74").Value = cell.Offset(0, 14).Value
        ws.Range("B76").Value = cell.Offset(0, 15).Value
      End Select
        End If
        
    Next cell

End Sub

Answer 1

我认为您要测试的是工作表是否存在，而不是工作表是否与您设置的名称匹配。看看下面的内容，我已经整理了一下，并使用错误处理来“测试”您设置名称的工作表是否存在

Sub Measures()
    Dim wb2 As Workbook
    Dim ws As Worksheet
    Dim Rng, Rng2 As Range
    Dim cell

    Set wb2 = Workbooks("November Stream 1 v2.xlsm")
    With ThisWorkbook.Worksheets("Summary")
        Set Rng = .Range("A7:A" & .cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    For Each cell In Rng
        On Error Resume Next
        Set ws = Nothing
        Set ws = wb2.Sheets(cell.Value2)
        On Error GoTo 0

        If Not ws Is Nothing Then
            Select Case ws.Range("A4").Value2
                Case "green"
                    ws.Range("B29").Value = cell.Offset(0, 1).Value
                    ws.Range("B33").Value = cell.Offset(0, 2).Value
                    ws.Range("B37").Value = cell.Offset(0, 3).Value
                    ws.Range("B40").Value = cell.Offset(0, 4).Value
                    ws.Range("B44").Value = cell.Offset(0, 5).Value

                Case "red"
                    ws.Range("B47").Value = cell.Offset(0, 6).Value
                    ws.Range("B51").Value = cell.Offset(0, 7).Value
                    ws.Range("B54").Value = cell.Offset(0, 8).Value
                    ws.Range("B60").Value = cell.Offset(0, 9).Value
                    ws.Range("B65").Value = cell.Offset(0, 11).Value

                Case "blue"
                    ws.Range("B68").Value = cell.Offset(0, 12).Value
                    ws.Range("B74").Value = cell.Offset(0, 14).Value
                    ws.Range("B76").Value = cell.Offset(0, 15).Value
            End Select
        End If
    Next cell
End Sub

Answer 2

尝试遍历 wb2 中的每个工作表，并将它们的名称与 wb1 中的当前单元格进行比较

作为psuedo（这是一个粗略的想法，我目前没有时间完整输入，抱歉）

for each cell. wb1.range("your range)
    wb2.activate
    for each worksheet in wb2
        if activesheet.name = cell.value then
            'do stuff
        else
            'do nothing
        end if
    next worksheet
next cell