Vba 根据条件将模板从不同工作簿复制到多个工作表上的特定单元格中

我正在努力编写代码，将模板从单独的工作簿复制粘贴到特定的单元格中。复制的模板因文本条件而异，文本条件位于模板应复制到的每张图纸上的单元格A4中

浏览总结工作簿上的每一页

在每张纸上，单元格A4中有一个特定的文本，该文本引用模板

打开包含多个模板工作表的模板工作簿。复制与摘要工作簿工作表单元格A4中的文本对应的模板

返回摘要工作簿上的工作表，然后将模板粘贴到单元格F14上。（因此，我必须在这里指定需要粘贴的整个单元格范围，还是只参考粘贴前应单击的单元格就可以了）

对摘要工作簿中的所有工作表重复此操作

下面是我所做的尝试，我得到了错误“应用程序定义的或对象定义的错误”，我在下面的代码中突出显示了触发错误的行。我认为这是因为我没有正确调用模板书页。此外，如果必须指定要复制和粘贴的单元格的确切范围，我也不会这样做，因为通常情况下，如果复制整个工作表，则只能将其粘贴为整个工作表，而不能从特定的单元格点粘贴

谢谢你的帮助

  Sub PASTE()

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

Set wb1 = ThisWorkbook
Set Sht = wb1.Worksheets("Summary")
Set Rng = Sht.Range("A6:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)

Dim TemplateBook As Workbook
Set TemplateBook = Workbooks.Open(Filename:="C:\Users\VBA-NOOB\Desktop\EVERY Colour.xlsx")
DoEvents

For Each cell In Rng
   Set ws = wb1.Sheets(cell.Text)
   Select Case ws.Range("A4").Value   
            Case "Red & Green T"
            ws.Range("F14").Value = TemplateBook.Sheets("Red & Green")  '<--- is causing the error

   End Select
   Next cell



   End Sub

子粘贴（）
将wb1设置为工作簿
将Sht变暗为工作表
变暗Rng、Rng2作为范围
暗淡单元格作为范围
将ws设置为工作表
设置wb1=ThisWorkbook
设置Sht=wb1。工作表（“摘要”）
设置Rng=Sht.Range（“A6:A”和Sht.Cells（Sht.Rows.Count，“A”）。结束（xlUp.Row）
Dim TemplateBook作为工作簿
Set TemplateBook=Workbooks.Open（文件名：=“C:\Users\VBA-NOOB\Desktop\EVERY color.xlsx”）
多芬特
对于Rng中的每个单元
设置ws=wb1.Sheets（cell.Text）
选择案例ws.Range（“A4”）值
案例“红色与绿色T”
ws.Range（“F14”）.Value=TemplateBook.Sheets（“红色和绿色”）'
…或类似，指定源区域的大小，而不是尝试使用“所有单元格”。
只是猜测。你能这样试试吗

Option Explicit

Sub PASTE()

    Dim wb1             As Workbook
    Dim Sht             As Worksheet
    Dim Rng             As Range
    Dim Rng2            As Range
    Dim cell            As Range
    Dim ws              As Worksheet
    Dim TemplateBook    As Workbook

    Dim rng3            As Range

    Set wb1 = ThisWorkbook
    Set Sht = wb1.Worksheets("Summary")
    Set Rng = Sht.Range("A6:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)

    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\VBA-NOOB\Desktop\EVERY Colour.xlsx")
    DoEvents

    For Each cell In Rng
        Set ws = wb1.Sheets(cell.Text)
        Select Case ws.Range("A4").Value
        Case "Red & Green T"

            ws.Range("F14") = TemplateBook.Sheets("Red & Green").Range("F14")  '<--- is causing the error

        End Select
    Next cell

End Sub

在本例中，您将图纸指定给一个范围。这是不可能的。
指定要从模板复制的范围，如下所示：

   Select Case ws.Range("A4").Value
            Case "Red & Green T"
            TemplateBook.Sheets("Red & Green").Range("F14:Z100").Copy
            ws.Activate
            Range("F14").Select
            ActiveSheet.PASTE
   End Select

请不要使用VBA标签！Thx@Peh用于编辑！；）是的，我希望F14作为要粘贴到的基本单元格。但是，对于不同的标准，有不同的模板。因此，如果表单中的单元格A4显示为红色和绿色，那么它应该从templatebook红色和绿色表单复制过去。在您编写的代码中，它没有指定要使用哪一个模板表，我也不知道如何使用，抱歉-我试图同时编写代码和聊天！我已经纠正了这一点，包括对模板手册的引用。关键部分是在
=
的两侧使用相同类型的对象。如果要为特定单元格或单元格范围赋值，则需要为其指定单元格引用、字符串、整数或类似值。我尝试了此操作，但未发生任何问题，模板文件已打开，但也没有错误或复制粘贴。我修改它来指定要复制的范围：ws.range（“F14”）=TemplateBook.Sheets（“红色和绿色”）.range（“E1:H623”），所以我不知道这是否是它不复制粘贴任何内容的原因
Option Explicit

Sub PASTE()

    Dim wb1             As Workbook
    Dim Sht             As Worksheet
    Dim Rng             As Range
    Dim Rng2            As Range
    Dim cell            As Range
    Dim ws              As Worksheet
    Dim TemplateBook    As Workbook

    Dim rng3            As Range

    Set wb1 = ThisWorkbook
    Set Sht = wb1.Worksheets("Summary")
    Set Rng = Sht.Range("A6:A" & Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row)

    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\VBA-NOOB\Desktop\EVERY Colour.xlsx")
    DoEvents

    For Each cell In Rng
        Set ws = wb1.Sheets(cell.Text)
        Select Case ws.Range("A4").Value
        Case "Red & Green T"

            ws.Range("F14") = TemplateBook.Sheets("Red & Green").Range("F14")  '<--- is causing the error

        End Select
    Next cell

End Sub

ws.Range("F14") = TemplateBook.Sheets("Red & Green").Range("F14")  

   Select Case ws.Range("A4").Value
            Case "Red & Green T"
            TemplateBook.Sheets("Red & Green").Range("F14:Z100").Copy
            ws.Activate
            Range("F14").Select
            ActiveSheet.PASTE
   End Select