Create Workbooks and Copy Template Worksheet to those Workbooks

K

K

A B……..col
Worksheets Workbooks……Headings
CC JIM
DD JIM
XX KIM
EE KIM
ZZ TIM
AA TIM

I have two worksheets in workbook. One name is "Sheet1" and the other
name is "Template". In "Sheet1" I have above list of data. I need to
create a unique workbook for every unique name in column B, while
copying the worsheet "Template" to new workbook and giving the
worksheets names which are in column A assigned to that workbook in
column B. I have research the group and found the macro below and
done few changes in it but its not working.


Macro*******************

Sub NewList()
Dim startrow As Long
Dim Templatesh As Worksheet
Dim rng As Range, cell As Range
Dim bk As Workbook
startrow = 2
Set Templatesh = Worksheets("Template")

With Worksheets("Sheet1")
Set rng = .Range(.Cells(startrow, 2), .Cells(startrow, 2).End(xlDown))
End With

For Each cell In rng
If cell.Value <> cell.Offset(-1, 0) Then
If Not bk Is Nothing Then bk.Close Savechanges:=True
Set bk = Workbooks.Add
Templatesh.Copy after:=bk.Worksheets(bk.Worksheets.Count)
ActiveSheet.Name = cell.Offset(0, -1)

bk.SaveAs "C:\My Document\Record\" & cell.Value & ".xlsx"

Else
Templatesh.Copy after:=bk.Worksheets(bk.Worksheets.Count)
ActiveSheet.Name = cell.Offset(0, -1)
End If
Next
If Not bk Is Nothing Then bk.Close Savechanges:=True
End Sub

****************************

I am getting error on line "Templatesh.Copy after:=bk.Worksheets
(bk.Worksheets.Count)". Please can any friend can help
 
J

Joel

I rewrote the code. I think the problem was not specifying THISWORKBOOK as
the starting workbook. When adding workbooks and worksheets the active sheet
keeps on changing. I also like using copy without after or before to create
a new workbook. It only makes a workbook with one sheet.

You could also of used
wrobooks.add(template:=xlWBATWorksheet)


Sub NewList()
Dim StartRow As Long
Dim LastRow As Long
Dim Templatesh As Worksheet
Dim rng As Range, cell As Range
Dim bk As Workbook
StartRow = 2
Set Templatesh = ThisWorkbook.Worksheets("Template")

With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Range("B" & 2).End(xlDown).Row
Set rng = .Range(.Cells(StartRow, "B"), .Cells(LastRow, "B").End(xlDown))
End With

OldbkName = ""
For Each cell In rng
If cell.Value <> OldbkName Then
'copy without after or before creates new workbook
Templatesh.Copy
Set newbk = ActiveWorkbook
Set newsht = ActiveSheet
newsht.Name = cell.Offset(0, -1)

OldbkName = cell.Value
Else
Templatesh.Copy _
after:=newbk.Sheets(newbk.Sheets.Count)
End If

If OldbkName <> cell.Offset(1, 0) Then
newbk.SaveAs "C:\My Document\Record\" & cell.Value & ".xlsx"
newbk.Close
End If
Next
End Sub
 
K

K

A B
C D………col
Worksheets Data_1 Data_2 Workbooks….hedings
CC 100 200 JIM
CC 100 200 JIM
XX 100 200 JIM
XX 100 200 JIM
VV 100 200 KIM
VV 100 200 KIM
AA 100 200 KIM
AA 100 200 KIM
RR 100 200 SAM

Thanks for replying joel, you been always very helpful. I want your
help little more. Lets say if I have above data and required same
thing which I mensioned in my above question but little different.
What changes can be done in your macro so I can achive result (see
below) according to above data.
1 - 3 Workbooks with name JIM , KIM & SAM (according to column D
uniqre value)
2 - Workbook JIM should have 2 worksheets with name CC & XX (according
to column A uniqre value)
2a - In cell A1 of Worksheet CC macro should put 200 and in cell B1
fig should be 400. (these are the total amount from column B & C which
appearing in next cell of sheet name)
2b - Same thing for Worksheet XX
3 - Prosses 2 , 2a & 2b should be repated on Workbook KIM & SAM

I'll be very greatful if you can solve this for me.
 
K

K

Sorry I have to repate as data text gone bit funny

A B C D………col
Worksheets Data_1 Data_2 Workbooks….hedings
CC 100 200 JIM
CC 100 200 JIM
XX 100 200 JIM
XX 100 200 JIM
VV 100 200 KIM
VV 100 200 KIM
AA 100 200 KIM
AA 100 200 KIM
RR 100 200 SAM

Thanks for replying joel, you been always very helpful. I want your
help little more. Lets say if I have above data and required same
thing which I mensioned in my above question but little different.
What changes can be done in your macro so I can achive result (see
below) according to above data.
1 - 3 Workbooks with name JIM , KIM & SAM (according to column D
uniqre value)
2 - Workbook JIM should have 2 worksheets with name CC & XX
(according
to column A uniqre value)
2a - In cell A1 of Worksheet CC macro should put 200 and in cell B1
fig should be 400. (these are the total amount from column B & C
which
appearing in next cell of sheet name)
2b - Same thing for Worksheet XX
3 - Prosses 2 , 2a & 2b should be repated on Workbook KIM & SAM


I'll be very greatful if you can solve this for me.
 
J

Joel

try these changes

Sub NewList()
Dim StartRow As Long
Dim LastRow As Long
Dim Templatesh As Worksheet
Dim rng As Range, cell As Range
Dim bk As Workbook
StartRow = 2
Set Templatesh = ThisWorkbook.Worksheets("Template")

With ThisWorkbook.Worksheets("Sheet1")
MstBkName = ThisWorkbook.Name
LastRow = .Range("B" & 2).End(xlDown).Row

OldbkName = ""
For RowCount = StartRow To LastRow
BkName = .Range("D" & RowCount).Value
If BkName <> OldbkName Then
ShtName = .Range("A" & RowCount).Value
'copy without after or before creates new workbook
Templatesh.Copy
Set newbk = ActiveWorkbook
Set NewSht = ActiveSheet
NewSht.Name = ShtName

OldbkName = BkName
Else
Templatesh.Copy _
after:=newbk.Sheets(newbk.Sheets.Count)
Set NewSht = ActiveSheet
NewSht.Name = ShtName
End If


Data_1 = Evaluate("SUMPRODUCT(" & _
"--(" & MstBkName & "!A" & RowCount & "=" & MstBkName & "!A$1:A$" &
LastRow & ")," & _
"--(" & MstBkName & "!D" & RowCount & "=" & MstBkName & "!D$1:D$" &
LastRow & ")," & _
MstBkName & "!B$1:B$" & LastRow & ")")

NewSht.Range("A1") = Data_1

Data_2 = Evaluate("SUMPRODUCT(" & _
"--(" & MstBkName & "!A" & RowCount & "=" & MstBkName & "!A$1:A$" &
LastRow & ")," & _
"--(" & MstBkName & "!D" & RowCount & "=" & MstBkName & "!D$1:D$" &
LastRow & ")," & _
MstBkName & "!C$1:C$" & LastRow & ")")

NewSht.Range("B1") = Data_2

If OldbkName <> cell.Offset(1, 0) Then
newbk.SaveAs "C:\My Document\Record\" & BkName & ".xlsx"
newbk.Close
End If
Next RowCount

End With

End Sub
 
J

Joel

I noticed you forgot the headings. I found some things wrong after I posted.
Try this instead

Sub NewList()
Dim StartRow As Long
Dim LastRow As Long
Dim Templatesh As Worksheet
Dim rng As Range, cell As Range
Dim bk As Workbook
StartRow = 2
Set Templatesh = ThisWorkbook.Worksheets("Template")

With ThisWorkbook.Worksheets("Sheet1")
MstBkName = ThisWorkbook.Name
LastRow = .Range("B" & 2).End(xlDown).Row

OldShtName = ""
OldBkName = ""
For RowCount = StartRow To LastRow
BkName = .Range("D" & RowCount).Value
ShtName = .Range("A" & RowCount).Value

If BkName <> OldBkName Then
ShtName = .Range("A" & RowCount).Value
'copy without after or before creates new workbook
Templatesh.Copy
Set newbk = ActiveWorkbook
Set NewSht = ActiveSheet
NewSht.Name = ShtName

NewSht.Range("A1") = 0

Data_2 = Evaluate("SUMPRODUCT(" & _
"--(" & MstBkName & "!A" & RowCount & "=" & MstBkName & _
"!A$1:A$" & LastRow & ")," & _
"--(" & MstBkName & "!D" & RowCount & "=" & MstBkName & _
"!D$1:D$" & LastRow & ")," & _
MstBkName & "!C$1:C$" & LastRow & ")")

OldBkName = BkName
OldShtName = ShtName
Else
If ShtName <> OldShtName Then
Templatesh.Copy _
after:=newbk.Sheets(newbk.Sheets.Count)
Set NewSht = ActiveSheet

NewSht.Range("A1") = 0
NewSht.Name = ShtName
OldShtName = ShtName
End If
End If

'this is a trick
'keep overwriting data, only last write gets saved.
NewSht.Range("A1") = NewSht.Range("A1") + .Range("A" & RowCount)
NewSht.Range("B1") = Data_2

If BkName <> .Range("D" & (RowCount + 1)) Then

newbk.SaveAs "C:\My Document\Record\" & BkName & ".xlsx"
newbk.Close
End If
Next RowCount

End With

End Sub
 
K

K

Hi Joel, Thanks for replying soon. Your macro works perfect just
small errors I found (see below)

1 -error coming on line below with message "run time error 13 - type
mismatch"
NewSht.Range("A1") = NewSht.Range("A1") + .Range("A" & RowCount)

2 - macro put correct total in sheet CC but in XX it put same total
which is in sheet CC. Lets say if I change amounts (see below)
       A             B             C                 D………col
Worksheets   Data_1     Data_2      Workbooks….hedings
    CC              100           200              JIM
    CC              200           300              JIM
     XX              300           400              JIM
     XX              400           500              JIM

Cell A1 of Sheet CC Total = 300
Cell B1 of Sheet CC Total = 500
Cell A1 of Sheet XX Total = 700
Cell B1 of Sheet XX Total = 900

The sultion is very close as if these two error will be solve then its
all done.
 
K

K

sorry i forgot to explain point 2 properly.

2 - macro put correct total in sheet CC but in XX it put same total
which is in sheet CC. Lets say if I change amounts (see below)
       A             B             C                 D………col
Worksheets   Data_1     Data_2      Workbooks….hedings
    CC              100           200              JIM
    CC              200           300              JIM
     XX              300           400              JIM
     XX              400           500              JIM

at the moment macro producing results (see below)

Cell A1 of Sheet CC Total = 0
Cell B1 of Sheet CC Total = 300
Cell A1 of Sheet XX Total = 0
Cell B1 of Sheet XX Total = 300

but result should be (see below)

Cell A1 of Sheet CC Total = 300
Cell B1 of Sheet CC Total = 500
Cell A1 of Sheet XX Total = 700
Cell B1 of Sheet XX Total = 900


The sultion is very close as if these two error will be solve then its
all done.
 
J

Joel

The only problem I'm inding is the line below I had to change column A to
column B.

This should fix the sheet total problem.

The Column C data problem is due to the correct formula below. I didn't
need to compare sheet names, only book names.


Data_2 = Evaluate("SUMPRODUCT(" & _
"--(" & MstBkName & "!D" & RowCount & "=" & MstBkName & _
"!D$1:D$" & LastRow & ")," & _
MstBkName & "!C$1:C$" & LastRow & ")")
 
K

K

I have changed below
NewSht.Range("A1") = NewSht.Range("A1") + .Range("A" & RowCount)
into
NewSht.Range("A1") = NewSht.Range("A1") + .Range("B" & RowCount)
and its much better but just only little thing that every 2nd sheet
created not getting correct total in cell B1. I tried changing codes
here and there but for strange reason i am still getting wrong total
in cell B1. Its only happening on second sheet as 1st sheet getting
totals perfect in both cells. any suggestion?
 
J

Joel

The code worked like I posted before. I reposted incase you accidently made
some changes. This is the data I tried.

Worksheets Data_1 Data_2 Workbooks….hedings
CC 100 200 JIM
CC 200 300 JIM
XX 300 400 JIM
XX 400 500 JIM
VV 500 600 KIM
VV 600 700 KIM
AA 700 800 KIM
AA 800 900 KIM
RR 900 1000 SAM


Sub NewList()
Dim StartRow As Long
Dim LastRow As Long
Dim Templatesh As Worksheet
Dim rng As Range, cell As Range
Dim bk As Workbook
StartRow = 2
Set Templatesh = ThisWorkbook.Worksheets("Template")

With ThisWorkbook.Worksheets("Sheet1")
MstBkName = ThisWorkbook.Name
LastRow = .Range("B" & 2).End(xlDown).Row

OldShtName = ""
OldBkName = ""
For RowCount = StartRow To LastRow
BkName = .Range("D" & RowCount).Value
ShtName = .Range("A" & RowCount).Value

If BkName <> OldBkName Then
ShtName = .Range("A" & RowCount).Value
'copy without after or before creates new workbook
Templatesh.Copy
Set newbk = ActiveWorkbook
Set NewSht = ActiveSheet
NewSht.Name = ShtName

NewSht.Range("A1") = 0

Data_2 = Evaluate("SUMPRODUCT(" & _
"--(" & MstBkName & "!D" & RowCount & "=" & MstBkName & _
"!D$1:D$" & LastRow & ")," & _
MstBkName & "!C$1:C$" & LastRow & ")")

OldBkName = BkName
OldShtName = ShtName
Else
If ShtName <> OldShtName Then
Templatesh.Copy _
after:=newbk.Sheets(newbk.Sheets.Count)
Set NewSht = ActiveSheet

NewSht.Range("A1") = 0
NewSht.Name = ShtName
OldShtName = ShtName
End If
End If

'this is a trick
'keep overwriting data, only last write gets saved.
NewSht.Range("A1") = NewSht.Range("A1") + .Range("B" & RowCount)
NewSht.Range("B1") = Data_2

If BkName <> .Range("D" & (RowCount + 1)) Then

' newbk.SaveAs "C:\My Document\Record\" & BkName & ".xlsx"
newbk.Close
End If
Next RowCount

End With

End Sub
 
J

Joel

You need to uncomment the saveas statement. I commented the line duing
testing and forgot to uncomment the line.
 
K

K

Thanks lot joel you been really very helpful. Its working perfect
now, may be i have missed something last time.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Set bk = Workbooks(...) 1
Problem w/code to copy worksheet to new workbook 10
Copy contents to a selected sheet in another workbook 1
Create Workbooks and then create Worksheets within them 2
range and sum? 5
Vaiable Help in VBA 5
Macro copy data into another workbook 5
Export specific cell values to an external workbook 1

Top