VBA - 根据汇总 Excel 表格上的条件，将工作簿中的不同模板工作表复制到另一个工作簿的多张工作表中

Question

I'm pretty new to VBA (3 days of exp), I have had a look through several forums but I can't find the solution.

I have 2 workbooks. The "master" workbook has a summary sheet with column A - List of names hyperlinked to a blank sheet each in the same workbook, the tabs are labelled the same as the name in the column. Column B has 1 or a combination of colour - there is 5 options (red, blue, green, blue & red, or red & green). I have a separate template workbook that has 5 template sheets each one corresponding to the colour: labelled red, blue, green, blue & red, or red & green.

I want a macro that will go through column B of my "master" workbook, and depending on the colour, copy the corresponding template from the template workbook and then go back to the master workbook click through the link in the adjacent column A, which will take it through to an empty sheet and paste the template. This should repeat to go through the entire column.

For example :

1. Recognises that Cell B2 in "master" workbook has the colour red.
2. Opens the template workbook,
3. go to the sheet labelled red
4. copy entire sheet
5. Go back to "master" workbook
6. click on the hyperlinked name in the cell (A2) next to B2
7. This will take you to a blank sheet
8. Paste the template
9. Go back to "Master" workbook and repeat for the rest of the column
10. If its red again, then do the same, if a different colour like blue, then copy paste the blue template sheet.

I have tried to write a code myself from what was available in other forums, but it only copy pastes onto the first 2 sheets of the "Master" workbook out of 10 sheets that requires the red template. I have only written it for 1 colour criteria so far since no point in adding multiple criteria if 1 isn't working:

Sub Summary()    
Dim rng As Range    
Dim i As Long    
Set rng = Range("B:B")   
For Each cell In rng       
If cell.Value <> "Red" Then cell.Offset(0, -1).select 
ActiveCell.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:= _
    "T:\Contracts\Colour Templates.xlsx"


Sheets("Red Template").Select
Cells.Select
Selection.Copy
Windows("Master.xlsx").Activate
ActiveSheet.Range(“A1”).select

ActiveSheet.Paste
Next
End Sub

Answer 1

Okay, so here's some code to get you started. I based the names on the code you gave, which is why it was helpful. I've commented this a lot to try and aid your learning, there are only actually about a dozen lines of code!

Note: this code will likely not work "as is". Try and adapt it, look at the Object Browser (press F2 in VBA editor) and documentation (add "MSDN" to Google searches) to help you.

Sub Summary()

    ' Using the with statement means any code phrase started with "." assumes the With bit first
    ' So ActiveSheet.Range("...") can now become .Range("...")

    Dim MasterBook As Workbook
    Set MasterBook = ActiveWorkbook

    Dim HyperlinkedBook As Workbook

    With MasterBook

        ' Limit the range to column 2 (or "B") in UsedRange
        ' Looping over the entire column will be crazy long!

        Dim rng As Range
        Set rng = Intersect(.UsedRange, .Columns(2))

    End With

    ' Open the template book
    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="T:\Contracts\Colour Templates.xlsx")

    ' Dim your loop variable
    Dim cell As Range
    For Each cell In rng

        ' Comparing values works here, but if "Red" might just be a
        ' part of the string, then you may want to look into InStr
        If cell.Value = "Red" Then
            ' Try to avoid using Select
            'cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

            ' You are better off not using hyperlinks if it is an Excel Document. Instead
            ' if the cell contains the file path, use

            Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value)

            ' If this is on a network drive, you may have to check if another user has it open.
            ' This would cause it to be ReadOnly, checked using If myWorkbook.ReadOnly = True Then ...

            ' Copy entire sheet
            TemplateBook.Sheets("Red Template").Copy after:=HyperlinkedBook.Sheets(HyperlinkedBook.Sheets.Count)

            ' Instead of copying whole sheet, copy UsedRange into blank sheet (copy sheet is better but here for learning)
            ' HyperlinkedBook.Sheets.Add after:=HyperlinkedBook.Sheets.Count
            ' TemplateBook.sheets("Red Template").usedrange.copy destination:=masterbook.sheets("PasteIntoThisSheetName").Range("A1")

        ElseIf cell.Value = "Blue" Then

            ' <similar stuff here>

        End If

    Next cell

End Sub

Use the Macro Recorder to help you learn how to do simple tasks:

http://www.excel-easy.com/vba/examples/macro-recorder.html

Try to then edit the code, and avoid using Select :

How to avoid using Select in Excel VBA macros

Answer 2

I've been trying to get the code to work for the past week with no luck. I tried various modifications, which ends up giving different error codes. The first Error I was getting was with Set rng = Intersect(.UsedRange, .Columns(2)) “Object doesn't support this property or method” So then I changed this to just going through the entire column just to see if it would work. Set rng = Range("B:B") . When I do that then it reads through and I get an error for Set HyperlinkedBook = Workbooks.Open(Filename:=cell.Offset(0, -1).Value) with the error code: run time error 1004 Sorry we couldn't find 24 James.xlsx. Is it possible it was moved, renamed or deleted?” I believe that this line of the code is assuming that the hyperlink should open a different workbook with that name, however this is not the case. The hyperlink on the summary sheet links through to other sheets on the same master workbook, only the templates are on a separate book. So to overcome this I tried changing this line as well and ended up with the code below, which manages to open the template workbook, and copy just the tab name onto the first sheet and then gives an error for the following line TemplateBook.Sheets("Red").Copy ActiveSheet.Paste , saying “subscript out of range”

Sub Summary()

    Dim MasterBook As Workbook
    Set MasterBook = ActiveWorkbook
    With MasterBook

        Dim rng As Range
        Set rng = Range("B:B")

    End With
    Dim TemplateBook As Workbook
    Set TemplateBook = Workbooks.Open(Filename:="C:\Users\Desktop\Example template.xlsx")

    Dim cell As Range
    For Each cell In rng
        If cell.Value = "Red" Then
        cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
            TemplateBook.Sheets("Red").Copy ActiveSheet.paste
        ElseIf cell.Value = "Blue" Then
cell.Offset(0, -1).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
            TemplateBook.Sheets("Blue").Copy ActiveSheet.paste
        End If

    Next cell

End Sub

I tried several more variations but I just can't get it to copy the correct template, switch back to the master workbook, follow through the link on the summary sheet to the correct sheet (within the same master workbook), and paste the template.