A macro to create new, copy and name worksheets based on a list Solved/Closed

Question

Greetings,
I need a macro that can automatically create new, copy (existing worksheet say '100') and rename the new worksheets, based on a list that exists in another sheet ("Summary") of the same workbook? The list begins from '100' at cell A2. How can this be implemented under Excel?

It will be great-full, if I am be helped with the solution.

vcoolio · Answer

Hello Chottabeem,

Could you please supply a sample of your work book (be careful with any sensitive data) outlining exactly what you would like to do.

Upload a sample to a free file sharing site such as DropBox, ge.tt or SpeedyShare and then post the link to your file back here.

We should then be able to help you.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Chottabeem,

Assuming that you only want to create and name new sheets from the list in the Summary sheet, then the following code will do that:-

Sub CreateNameNewSheets()

Dim LR As Long
    Dim c As Range
    Dim ws As Worksheet
LR = Range("A" & Rows.Count).End(xlUp).Row
    
For Each c In Range("A2:A" & LR)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        If ws Is Nothing Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c
End Sub

If you intend to use just numbers as the sheet names, then you will need to format those numbers as text otherwise, each time that you run the code, you will have additional and unwanted sheets added that will just have sheet numbers as names.

Run the code from the Summary sheet.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Chottabeem,

I don't follow what you are trying to do. Are you saying that you would like the data in sheet1 transferred to each newly created sheet for each Supplier?

Cheerio,
vcoolio

P.S.
"Hope I clarified and expect the right solution."
Just a tip. Never use the word "expect" in any Forum such as this.
On this Forum, and all others like it, the people who help others such as yourself, are all Volunteers and give their time freely whenever they can to help. Hence, Posters are not in a position to expect anything.

Please familiarise yourself with the Charter.

I trust that you understand.

vcoolio · Answer

Hello Chottabeem,

I assume that you have answered "yes" to my question. If so, would you not prefer to name each sheet after each Supplier (or at least use a Supplier ID). You would not then need a Summary sheet. You could just use sheet1 as an Input sheet and perhaps name it Data Input.
Any new data that you enter, even for new Suppliers, could be quickly updated with the click of a button.

This would simplify the whole process for you.

Let us know what you think of this approach.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Chottabeem,

I have attached your work book (see the link below) with some minor changes which I think you will like:-

https://www.dropbox.com/s/dwpzvk2qsmg3i8m/Chottabeem%28create%20shts.%2C%20transfer%20data%2C%20autofilter%29.xlsm?dl=0

I have added the following code which creates the new sheets and transfers the relevant data to each individual sheet:-

Option Explicit
Sub CreateSheetsCopyData()

Dim ar As Variant
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet, ws1 As Worksheet

Set ws1 = Worksheets("Data Input")
LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
ar = ws1.Range("B6", ws1.Range("B" & ws1.Rows.Count).End(xlUp))

Application.ScreenUpdating = False

For Each c In ws1.Range("B6:B" & LR)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        If ws Is Nothing Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c

For i = 0 To UBound(ar)
         Sheets(ar(i, 1)).UsedRange.ClearContents
         ws1.Range("B5", ws1.Range("B" & ws1.Rows.Count).End(xlUp)).AutoFilter 1, ar(i, 1)
         ws1.[A5].CurrentRegion.Copy Sheets(ar(i, 1)).Range("A" & Rows.Count).End(xlUp)
         Sheets(ar(i, 1)).Columns.AutoFit
    Next i
ws1.[B5].AutoFilter
ws1.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Sheets created/Data transfer completed!", vbExclamation, "Status"

End Sub

You may notice that I have re-named sheet1 as "Data Input" and your previous Summary sheet to "List". The "List" sheet simply lists your Suppliers' names and an ID which I randomly created with the numbers that you already had in the sheet. The main reason for placing an "A" in front of the numbers is so that the IDs are recognised as text otherwise the code will falter.

In the "Data Input" sheet, I have inserted a column (named Supplier ID) before the Suppliers Name column and placed the Supplier IDs in this column. You can change the IDs to suit yourself but remember to include some text in them.

As some of your Suppliers' names surpass the 31 character limit for sheet tab names, the code will hence search and filter for the Supplier IDs, create new sheets named after the IDs and then transfer the relevant data for each Supplier to their individual sheet.

You may also notice that I have unmerged the column headings row as merged cells play havoc with VBA coding. As you can see, it hasn't made much difference to your formatting. I have also "unwrapped" all text over the entire sheet as this was previously randomly placed over the data set for no apparent reason.

In the sample file in the link mentioned above, just click on the "RUN" button to see it all work. The code is in Module1.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Chottabeem,

You're welcome. Glad that I could help.

I'll leave it to you to mark this thread as solved.

Cheerio,
vcoolio.

Devil77 · Answer

hi.. ive made some changes to sl no. column.. the requirement is i need to filter different supplier id according to different sl no.. which means supplier id A70 will have two different sheets where one sheet will have sl no a1 and the other will have sl no. 2.. the sheet name can the supplier id or anything..the same with other supplier id too..so every supplier id will have different sl no. and they need to create new sheets according to them..so if a supplier id ex.A60 have three diiferent sl no. then that supplier id will have three sheets with same supplier id A60 and sl no. accordingly.. could you help?

vcoolio · Answer

Hello Devil77,

I believe that the following code, placed in a standard module and assigned to a button, should work for you:-

Option Explicit

Sub CreateSheetsTransferData()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

lr = Range("A" & Rows.Count).End(xlUp).Row

ar = Sheet1.Range("I3", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp))
Set sh = Sheet1

For i = LBound(ar) To UBound(ar)
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1)
        End If
        Set ws = Worksheets(CStr(ar(i, 1)))
        sh.Range("I2:I" & lr).AutoFilter 1, ar(i, 1)
        sh.Range("A1", sh.Range("H" & sh.Rows.Count).End(xlUp)).Copy ws.[A1]
        ws.Columns.AutoFit
  Next i
sh.[I2].AutoFilter

Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS"

End Sub


Following is the link to a sample that I have created based on your explanation:-

https://www.dropbox.com/s/3oji4egtx1xyj4b/Devil77%28Create%20shts%20from%20list%2C%20transfer%20data%29.xlsm?dl=0

Click on the "RUN" button to see it work.

To create different sheets for the same supplier, I have used the TEXTJOIN function to basically concatenate the SI No, the Supplier ID and the Supplier Name to create a unique ID which will allow you to have separate sheets for the same Supplier. The relevant rows of data are then transferred to their respective individual sheet.

So, in Column I, which I have named "Sheet Name List", place the following formula in cell I3 and copy it down as far as you need:-

=TEXTJOIN("",TRUE,A3,B3,C3)

This will create the unique ID list for each Supplier which the code will use to create the new sheets.

Test it all in a copy of your work book first.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Devil77,

The first link that you supplied does not work and the second is completely different from the screen shot that you supplied, as is your explanation.
To make things simpler, in future please post your queries exactly and clearly as they should be. If you don't, how are we supposed to help? We cannot read minds!

In the sample that you supplied, why have you placed the code in the sheet module and not a standard module? If you place that same code in a standard module and delete it from the sheet module, it should create two new sheets based on the list of IDs in Column I. 

As for the rest, you are going to have to give us a much clearer explanation.
You would be best to give us a manual (in a sample work book) example of the expected result.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Devil77, Ok. Following is a "rough and ready" code which should get you started:- Sub TransferData() Dim i As Integer Application.ScreenUpdating = False Sheet2.Columns.AutoFit For i = 2 To 96 '-----> Your data set appears to be set at 96 rows. If Left(Cells(i, 8), 3) = "RMA" And Cells(i, 9) = 541466 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) Sheet3.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) <> "RMA" And Cells(i, 9) = 541466 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) Sheet4.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) <> "RMA" And Cells(i, 9) = 532455 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet5.Range("A" & Rows.Count).End(3)(2) Sheet5.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) = "RMA" And Cells(i, 9) = 532455 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet6.Range("A" & Rows.Count).End(3)(2) Sheet6.Columns.AutoFit End If Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub This code doesn't actually create new sheets so manually create one sheet formatted as per your "FG Report" sheet and then copy this sheet three more times. Name them what you like as I have used the sheet code in the macro above to reference the sheets so what they are named won't matter. Place the above macro code in a standard module (not the sheet module) and assign it to a button or create a shortcut key to execute the code. Again, test it in a copy of your work book first. I hope that this helps. Cheerio, vcoolio.

vcoolio · Answer

Hello Devil77,

I have tested the code and I don't have any errors arising. Did you use the code in post #28?

Regardless, following is a more compact code which will do the same task:-


Sub CreateSheetsTransferData()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

Sheet2.Range("T2:T96").Formula = "=IF(LEFT(H2,3)=""RMA"",""RMA"",""Non-RMA"")&I2"
lr = Range("A" & Rows.Count).End(xlUp).Row

ar = Sheet2.Range("T2", Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp))
Set sh = Sheet2

For i = LBound(ar) To UBound(ar)
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1)
        End If
        Set ws = Worksheets(CStr(ar(i, 1)))
        sh.Range("T1:T" & lr).AutoFilter 1, ar(i, 1)
        sh.[A1].CurrentRegion.Copy ws.[A8]
        ws.Columns.AutoFit
  Next i
    
sh.[T1].AutoFilter
sh.Columns(20).ClearContents

Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
MsgBox "All done!", vbExclamation, "STATUS"

End Sub

Let me know how it goes.

Cheerio,
vcoolio.

A macro to create new, copy and name worksheets based on a list

11 responses

Similar discussions

Subscribe To Our Newsletter!