Automatic new worksheet creation at each change of value in a first worksheet

[benjamin.mangelinckx]

Hi,

I have a worksheet with all my supplier invoices.
In colum "A", I have the supplier name.
In all other columns I have the details of the invoices.

I want to have a macro that sort the sheet on column A, then
automatically create a worksheet per supplier with all invoices.

This mean at each change of supplier name, I want a new worksheet with
the invoices of this supplier.

I wonder if you could give me some hints ...

Thanks a lot

Benjamin

 

[michael.beckinsale]

Hi Benjamin,

I wrote this code the other day and it does what you want. Use it as a
basis and amend to suit.
ie
1) "A&O List - Unique Prisons" should be the worksheet with your unique
list of suppliers
2) "Full A&O List" should be the worksheet with your list of invoices
3) Your list of invoices must be sorted so that each supplier /
customer is grouped together.
4) 138 should be amended to the number of unique suppliers. better
still use code to determine.

I created some 200 sheets in approx 5 seconds!

Sub CreatePrisonSheets()

Dim tabname As String
Dim startrow As Long
Dim endrow As Long

Application.ScreenUpdating = False
Sheets("A&O List - Unique Prisons").Activate
Range("A2").Activate
For i = 1 To 138 >>>>>>>>>>>>>>>Amend to find the lastrow
tabname = ActiveCell.Value
Sheets.Add
ActiveSheet.Name = tabname
Sheets("Full A&O List").Range("A1:L1").Copy Destination:=Sheets
_(tabname).Range("A1")
Sheets("Full A&O List").Activate
Range("A1").Activate
startrow = Cells.Find(What:=tabname, After:=ActiveCell,
LookIn:=xlValues, _
LookAt:=xlWhole,
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False,
SearchFormat:=False).Row
Range("A65536").Activate
endrow = Cells.Find(What:=tabname, After:=ActiveCell,
LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Row
Range("A" & startrow & ":L" & endrow).Copy
Destination:=Sheets(tabname).Range("A2")
Sheets("A&O List - Unique Prisons").Activate
ActiveCell.Offset(1, 0).Activate
Application.CutCopyMode = False
Next i
End Sub

Let me know how you get on

Regards

Michael Beckinsale

 

[benjamin.mangelinckx]

Thanks Michael

It worked ...

I made it that way:

Sub CreatePrisonSheets()

Dim tabname As String
Dim sheetname As String
Dim startrow As Long
Dim endrow As Long
'Dim records As Integer

Sheets("File_Approval").Activate
ActiveSheet.Range("A1").EntireColumn.Insert
Range("B1:B65356").AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=Range("A1"), Unique:=True

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row

ActiveSheet.Range("L1") = iLastRow

Application.ScreenUpdating = False
Sheets("File_Approval").Activate
Range("A2").Activate
For i = 1 To (iLastRow - 1) ' >>>>>>>>>>>>>>>Amend to find the
lastrow
tabname = ActiveCell.Value
'MsgBox (ActiveCell.Value)
Sheets.Add
sheetname = Left(tabname, 30)
ActiveSheet.Name = sheetname
Sheets("File_Approval").Range("B11").Copy
Destination:=Sheets(sheetname).Range("A1")
Sheets("File_Approval").Activate
Range("B1").Activate
startrow = Cells.Find(What:=tabname, After:=ActiveCell,
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns,
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row
Range("B65536").Activate
endrow = Cells.Find(What:=tabname, After:=ActiveCell,
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
Range("B" & startrow & "" & endrow).Copy
Destination:=Sheets(sheetname).Range("A2")

'Sheets("Full A&O List").Activate
a = 2 + i
'MsgBox (a)
Worksheets("File_Approval").Range("A" & a).Activate
'MsgBox (ActiveCell.Value)
'ActiveCell.Offset(1, 0).Activate
Application.CutCopyMode = False

Next i

End Sub





michael.beckinsale schreef: