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

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" wrote:

> 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
>

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.

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.

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$" &
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$" &
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


"K" wrote:

> 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.
>

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$" & 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" wrote:

> 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.
>

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.

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.

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$" & LastRow & ")," & _
MstBkName & "!C$1:C$" & LastRow & ")")



"K" wrote:

> 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.
>
>
>

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?