VBA to create new tab on base on an identifier

O

Obwan

Board Regular
Joined
May 14, 2012
Messages
56
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I am hoping one of you VBA gurus can help me with a script to separate rows of data into multiple sheets in a workbook.
The data is in 5 columns over 1000s of rows for many customers. I cannot export the data any other way.
Column A has:

  • 0 (zero) - Header row to show the change from one customer’s information to the next.
  • A – sub header
  • B – detail
On the row where 0 is in column 1, the customer name is in column B.
What I want is to create a new tab for each customer. I need a script which…. Each time it finds a 0 in column A it takes the rows of data and copies it to a new tab and renames the tab the code in column B of the header line. The script stops at the next 0 and runs again.
I can do this manually by copying and pasting but there are 100s. I am trying (with your help) make life easier for our sales team.
Any help will be gratefully received. Thank you for taking to the time to reads this.
Regards
Obwan
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
.
Here is one method :

Code: 
Option Explicit


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


        Set RngBeg = Worksheets("Sheet1").Range("B2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp)


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)


                ' Add a new worksheet and name it.
                If Wks.Name <> Cell.Value Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error GoTo M
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
Dim ans As String
    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 2).Value
        Sheets("Sheet1").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
Application.ScreenUpdating = True


Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select


Exit Sub


M:
MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True


End Sub
 
Upvote 0
I just ran a test on small amount of data. It didn’t quite work out. I can see the how it would work but I think my failure to give you a sample didn’t help (sorry).
When I ran the scripts the result was dozens of tabs with 1 line of data on each.
I made up this dummy data to show you how it looks. There are usually about 300 lines per customer, with several sub headings. This example should result in 4 tabs.


[TABLE="width: 315"]
<tbody>[TR]
[TD]0[/TD]
[TD]Customer1[/TD]
[TD][/TD]
[TD][/TD]
[TD]6/09/2019[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Stationery[/TD]
[TD][/TD]
[TD]Price[/TD]
[TD]RRP[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]111111[/TD]
[TD]Pen[/TD]
[TD] $ 1.20 [/TD]
[TD] $ 1.50 [/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]222222[/TD]
[TD]Paper[/TD]
[TD] $ 2.00 [/TD]
[TD] $ 2.75 [/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Furniture[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]333333[/TD]
[TD]Desk[/TD]
[TD] $ 129.61 [/TD]
[TD] $ 200.00 [/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]Customer2[/TD]
[TD][/TD]
[TD][/TD]
[TD]6/09/2019[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Stationery[/TD]
[TD][/TD]
[TD]Price[/TD]
[TD]RRP[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]111111[/TD]
[TD]Pen[/TD]
[TD] $ 1.20 [/TD]
[TD] $ 1.50 [/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]222222[/TD]
[TD]Paper[/TD]
[TD] $ 2.00 [/TD]
[TD] $ 2.75 [/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Furniture[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]333333[/TD]
[TD]Desk[/TD]
[TD] $ 150.00 [/TD]
[TD] $ 200.00 [/TD]
[/TR]
[TR]
[TD]0[/TD]
[TD]Customer3[/TD]
[TD][/TD]
[TD][/TD]
[TD]6/09/2019[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Stationery[/TD]
[TD][/TD]
[TD]Price[/TD]
[TD]RRP[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]111111[/TD]
[TD]Pen[/TD]
[TD] $ 1.10 [/TD]
[TD] $ 1.50 [/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]222222[/TD]
[TD]Paper[/TD]
[TD] $ 1.75 [/TD]
[TD] $ 2.75 [/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Furniture[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]333333[/TD]
[TD]Desk[/TD]
[TD] $ 115.00 [/TD]
[TD] $ 200.00 [/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]Customer4[/TD]
[TD][/TD]
[TD][/TD]
[TD]6/09/2019[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Stationery[/TD]
[TD][/TD]
[TD]Price[/TD]
[TD]RRP[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]111111[/TD]
[TD]Pen[/TD]
[TD] $ 1.20 [/TD]
[TD] $ 1.50 [/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]222222[/TD]
[TD]Paper[/TD]
[TD] $ 1.90 [/TD]
[TD] $ 2.75 [/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]Furniture[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]333333[/TD]
[TD]Desk[/TD]
[TD] $ 160.00 [/TD]
[TD] $ 200.00 [/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
[TABLE="class: cms_table"]
<tbody>[TR]
[TD]B[/TD]
[TD]Customer4[/TD]
[TD][/TD]
[TD][/TD]
[TD]6/09/2019[/TD]
[/TR]
</tbody>[/TABLE]

Why Customer4 has B not 0?
 
Upvote 0
I don’t quite understand what you want but maybe this:
The code will creates multiple sheets, each will be named by each customer.
It copies all data from each customer to the new sheet accordingly.
If this is not what you expect then please explain in more detail. What is the result should look like (for example for customer1)?

Code: 
[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] a1109080a()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1109080-vba-create-new-tab-base-identifier.html#post5337942[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], j [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] c [COLOR=Royalblue]As[/COLOR] Range
[COLOR=Royalblue]Dim[/COLOR] ws [COLOR=Royalblue]As[/COLOR] Worksheet
[COLOR=Royalblue]Dim[/COLOR] va
[COLOR=Royalblue]Dim[/COLOR] wsName [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]

Application.ScreenUpdating = [COLOR=Royalblue]True[/COLOR]
[COLOR=Royalblue]Set[/COLOR] ws = ActiveSheet

[COLOR=Royalblue]With[/COLOR] ws
va = .Range([COLOR=brown]"A1"[/COLOR], .Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))

[COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
    
    [COLOR=Royalblue]If[/COLOR] va(i, [COLOR=crimson]1[/COLOR]) = [COLOR=brown]"0"[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        
        j = i
            [COLOR=Royalblue]Do[/COLOR]
                i = i + [COLOR=crimson]1[/COLOR]
                [COLOR=Royalblue]If[/COLOR] i > UBound(va, [COLOR=crimson]1[/COLOR]) [COLOR=Royalblue]Then[/COLOR] [COLOR=Royalblue]Exit[/COLOR] [COLOR=Royalblue]Do[/COLOR]
            [COLOR=Royalblue]Loop[/COLOR] [COLOR=Royalblue]While[/COLOR] va(i, [COLOR=crimson]1[/COLOR]) <> [COLOR=brown]"0"[/COLOR]
        i = i - [COLOR=crimson]1[/COLOR]
        
        wsName = .Cells(j, [COLOR=brown]"B"[/COLOR])
        [COLOR=Royalblue]Set[/COLOR] c = .Range(.Cells(j, [COLOR=brown]"A"[/COLOR]), .Cells(i, [COLOR=brown]"E"[/COLOR]))
            
            [COLOR=Royalblue]If[/COLOR] [COLOR=Royalblue]Not[/COLOR] Evaluate([COLOR=brown]"ISREF('"[/COLOR] & wsName & [COLOR=brown]"'!A1)"[/COLOR]) [COLOR=Royalblue]Then[/COLOR]
                 Sheets.Add(after:=Sheets(Sheets.count)).Name = wsName
                 c.Copy Range([COLOR=brown]"A1"[/COLOR])
                 Columns([COLOR=brown]"A:E"[/COLOR]).AutoFit
            [COLOR=Royalblue]Else[/COLOR]
                 MsgBox [COLOR=brown]"Sheet's name already exist?"[/COLOR]
            [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
       
    [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
    
[COLOR=Royalblue]Next[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]With[/COLOR]
Application.ScreenUpdating = [COLOR=Royalblue]False[/COLOR]

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]
 
Upvote 0
The result is exactly what I wanted. Thank you Akuini. This is going to save me days of work.
Appreciate the help you and Logit have given.
I apologise for my poor explanation, I do try to explain correctly but seem to miss the little but important facts.
Regards
Olwyn
 
Upvote 0
You're welcome, glad to help, & thanks for the feedback.:)
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Copy value of column A to another tab is value in column D
Replies
1
Views
38
Joe4
Joe4
B
  • Solved
Office Script for auto fill to last row of adjacent column
Replies
6
Views
307
ExcelToDAX
E
W
  • Question Question
Macro/VBA code code for creating new excel file for each pivot table from a column filter
Replies
1
Views
419
Anthony47
A
S
  • Question Question
Copy rows from multiple worksheets into multiple worksheets in another workbook based on criteria
Replies
1
Views
304
eiloken
E
Y
  • Question Question
VBA Code to activate the tab and and transfer data
Replies
1
Views
235
Joe4
Joe4

Forum statistics

Threads
1,223,714
Messages
6,174,050
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top