Help! Macro to copy worksheet from different templates

[echane]

Hi!

I'm a complete newbie with VBA so I can't quite figure out how to do the following. I'm sure it's probably very easy for some of you out there. I've attached an excel of an example of what I want to do.

I want a macro that will copy information from one worksheet to a new one based on one of two possible templates. In the file, I have a "Data" tab and two template tabs that are different. I have silly information in the data tab like different fruits and vegetables right now. I want to be able to run a macro that will go down the list of different fruits and vegetables and create a new worksheet for each one from a template. I don't want a new worksheet for every single one though, only the ones where in the data tab, the column labeled "Report" says "Yes". I have a column in there that labels each entry as either a fruit or vegetable. I want the macro to know that if it's labeled "fruit" it'll copy the "fruit template" and likewise for vegetables. I would also like the new worksheets to be named what it is in Column A of the "Data" tab.

In addition, I want each new worksheet to be prepopulated with certain information like the Product name, ID, and these other "Category x" fields. Ideally, the point is after each worksheet is generated, I can fill in more specific information for each product in the boxes labeled "Field" on the template.

I have one last tab in there called "Apples" that shows what I want a new worksheet to look like.

Sorry if I'm not good at explaining. The attached file should make it clearer. Thanks in advance!

[Bob Phillips]

Rename Vegetable template to Vegetables Template and use



Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim sh As Worksheet

Set sh = Worksheets("Data")
With sh

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 5 To LastRow

If .Cells(i, "H").Value = "Yes" Then

Worksheets(.Cells(i, "C").Value & " Template").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = .Cells(i, "A").Value
.Cells(i, "A").Copy
ActiveSheet.Range("B4").PasteSpecial Paste:=xlPasteValues
.Cells(i, "B").Copy
ActiveSheet.Range("B5").PasteSpecial Paste:=xlPasteValues
.Cells(i, "D").Copy
ActiveSheet.Range("B7").PasteSpecial Paste:=xlPasteValues
.Cells(i, "E").Copy
ActiveSheet.Range("B8").PasteSpecial Paste:=xlPasteValues
.Cells(i, "F").Copy
ActiveSheet.Range("B9").PasteSpecial Paste:=xlPasteValues
.Cells(i, "G").Copy
ActiveSheet.Range("B10").PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
End Sub

[echane]

Thank you so much! That code is so helpful! I did have another question though. What can I add to that code so it won't have any problems when I add a new row of data to the Data tab? Say, if I had already generated some of the worksheets but I subsequently added another entry to the data tab, how can I get it to only add that new worksheet when I run the macro again? Right now it has the error for creating a worksheet with the same name as one that's already there. Thanks again so much!

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim Sh As Worksheet

Set Sh = Worksheets("Data")
With Sh

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 5 To LastRow

If .Cells(i, "H").Value = "Yes" Then

If Not SheetExists(Worksheets(.Cells(i, "C").Value & " Template")) Then

Worksheets(.Cells(i, "C").Value & " Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = .Cells(i, "A").Value
.Cells(i, "A").Copy
ActiveSheet.Range("B4").PasteSpecial Paste:=xlPasteValues
.Cells(i, "B").Copy
ActiveSheet.Range("B5").PasteSpecial Paste:=xlPasteValues
.Cells(i, "D").Copy
ActiveSheet.Range("B7").PasteSpecial Paste:=xlPasteValues
.Cells(i, "E").Copy
ActiveSheet.Range("B8").PasteSpecial Paste:=xlPasteValues
.Cells(i, "F").Copy
ActiveSheet.Range("B9").PasteSpecial Paste:=xlPasteValues
.Cells(i, "G").Copy
ActiveSheet.Range("B10").PasteSpecial Paste:=xlPasteValues
End If
End If
Next i
End With
End Sub

Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
End Function

[echane]

I hate to be a bother but there's a compile error when I run this code saying "Sub or Function not defined".

[echane]

whoops, i apologize. That's not the right error. I get a run-time error. Object doesn't support this property or method and it highlights the "if not sheetexists" line.

[Bob Phillips]

Sorry, my error



Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim Sh As Worksheet

Set Sh = Worksheets("Data")
With Sh

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 5 To LastRow

If .Cells(i, "H").Value = "Yes" Then

If Not SheetExists(.Cells(i, "C").Value & " Template") Then

Worksheets(.Cells(i, "C").Value & " Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = .Cells(i, "A").Value
.Cells(i, "A").Copy
ActiveSheet.Range("B4").PasteSpecial Paste:=xlPasteValues
.Cells(i, "B").Copy
ActiveSheet.Range("B5").PasteSpecial Paste:=xlPasteValues
.Cells(i, "D").Copy
ActiveSheet.Range("B7").PasteSpecial Paste:=xlPasteValues
.Cells(i, "E").Copy
ActiveSheet.Range("B8").PasteSpecial Paste:=xlPasteValues
.Cells(i, "F").Copy
ActiveSheet.Range("B9").PasteSpecial Paste:=xlPasteValues
.Cells(i, "G").Copy
ActiveSheet.Range("B10").PasteSpecial Paste:=xlPasteValues
End If
End If
Next i
End With
End Sub

Function SheetExists(Sh As String, _
Optional wb As Workbook) As Boolean
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error Goto 0
End Function