VBA Create new sheet based on customer #, and populate table for each sheet

[csimonds]

Hi,
I have a database of customer accounts and open invoices in one sheet (MasterSheet)
I have a CustomerTemplate sheet, which is the template I would like to fill for each customer.

I am trying to achieve the following;

1. Create a new sheet of CustomerTemplate for each customer, naming each sheet customer number (Col. B MasterSheet)
2. In each new customer sheet, copy Customer Number into cell: B3
3. In each new customer sheet, copy Customer Name into cell: B4
4. Each customer sheet has a table with 7 fields. These are:
   
   [TABLE="class: grid, width: 500"]
   <tbody>[TR]
   [TD]Invoice Number[/TD]
   [TD]Type[/TD]
   [TD]Date of Issue[/TD]
   [TD]Due Date[/TD]
   [TD]Amount[/TD]
   [TD]Comment[/TD]
   [TD]Reference[/TD]
   [/TR]
   [TR]
   [TD]Col. D[/TD]
   [TD]Col.E[/TD]
   [TD]Col.N[/TD]
   [TD]Col.T[/TD]
   [TD]Col.P[/TD]
   [TD]Col.K[/TD]
   [TD]Col.L[/TD]
   [/TR]
   </tbody>[/TABLE]
   * Columns above, refer to MasterSheet columns of original data.
5. I would like the macro to copy for each customer each line into their customer sheet, in the table.
6. Each customer will have 1 or more invoices (lines) in MasterSheet

If anyone can assist me with a VBA for this it would be appreciated.

Thank you,

 

[mumps]

In which column in the MasterSheet is the Customer Name? In which row of the customer sheet are the field headers?

 

[csimonds]

In which column in the MasterSheet is the Customer Name? In which row of the customer sheet are the field headers?

CustomerName is in Col. C of MasterSheet

The field headers are in Row 6 (starting Col. A) of CustomerTemplate sheet.

Thank you.

 

[vcoolio]

Hello CSimonds,

See if the following code does the task for you:-

Option Explicit

Sub Test()
    
        Dim wsM As Worksheet, wsT As Worksheet
        Dim lr As Long, i As Long, x As Long, nRow As Long
        Dim cAr As Variant, pAr As Variant, key As Variant
        Dim ID As Object
        
        Set ID = CreateObject("Scripting.Dictionary")
        Set wsT = Sheets("Template")
        Set wsM = Sheets("Master")
        lr = wsM.Range("A" & Rows.Count).End(xlUp).Row
        'wsM.Range("A2", wsM.Range("T" & wsM.Rows.Count).End(xlUp)).Sort wsM.[B2], 1
        cAr = Array("D2:D" & lr, "E2:E" & lr, "N2:N" & lr, "T2:T" & lr, "P2:P" & lr, "K2:K" & lr, "L2:L" & lr, "C2:C" & lr)
        pAr = Array("A", "B", "C", "D", "E", "F", "G", "H")
    
Application.ScreenUpdating = False

For i = 2 To lr
       If Not ID.Exists(wsM.Range("B" & i).Value) Then
            ID.Add wsM.Range("B" & i).Value, 1
       End If
Next i

For Each key In ID.keys
        If Not Evaluate("ISREF('" & key & "'!A1)") Then
        wsT.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = key
        End If
wsM.Range("B1:B" & lr).AutoFilter 1, key
For x = LBound(cAr) To UBound(cAr)
        nRow = Sheets(key).Cells(Rows.Count, 8).End(xlUp).Row + 1
        wsM.Range(cAr(x)).Copy Sheets(key).Range(pAr(x) & nRow)
        wsM.[B1].AutoFilter
Next x
        Sheets(key).[B3] = Sheets(key).Name
        Sheets(key).[B4] = Sheets(key).[H7].Value
        Sheets(key).Columns.AutoFit
        Sheets(key).Columns(8).ClearContents
Next key
 
wsM.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

In the code above, I have commented out the sort line of the code. If you wish to activate this line, just remove the apostrophe at the front of the line of code. This line may help with better efficiency should your data set be reasonably large.

Please test the code in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.

 

[vcoolio]

Hello again CSimonds,

I've just found a little error in the code so here it is again:-

Option Explicit

Sub Test()
    
        Dim wsM As Worksheet, wsT As Worksheet
        Dim lr As Long, i As Long, x As Long, nRow As Long
        Dim cAr As Variant, pAr As Variant, key As Variant
        Dim ID As Object
        
        Set ID = CreateObject("Scripting.Dictionary")
        Set wsT = Sheets("Template")
        Set wsM = Sheets("Master")
        lr = wsM.Range("A" & Rows.Count).End(xlUp).Row
        'wsM.Range("A2", wsM.Range("T" & wsM.Rows.Count).End(xlUp)).Sort wsM.[B2], 1
        cAr = Array("D2:D" & lr, "E2:E" & lr, "N2:N" & lr, "T2:T" & lr, "P2:P" & lr, "K2:K" & lr, "L2:L" & lr, "C2:C" & lr)
        pAr = Array("A", "B", "C", "D", "E", "F", "G", "H")
    
Application.ScreenUpdating = False

For i = 2 To lr
       If Not ID.Exists(wsM.Range("B" & i).Value) Then
            ID.Add wsM.Range("B" & i).Value, 1
       End If
Next i

For Each key In ID.keys
        If Not Evaluate("ISREF('" & key & "'!A1)") Then
        wsT.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = key
        End If
wsM.Range("B1:B" & lr).AutoFilter 1, key
For x = LBound(cAr) To UBound(cAr)
        nRow = Sheets(key).Cells(Rows.Count, 8).End(xlUp).Row + 1
        wsM.Range(cAr(x)).Copy Sheets(key).Range(pAr(x) & nRow)
Next x
        Sheets(key).[B3] = Sheets(key).Name
        Sheets(key).[B4] = Sheets(key).[H7].Value
        Sheets(key).Columns.AutoFit
        Sheets(key).Columns(8).ClearContents
        wsM.[B1].AutoFilter
Next key
 
wsM.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Also, if it helps, following is the link to a little sample that I've prepared for you. I assume that it's set out is similar to your actual workbook.

http://ge.tt/2aS58Oq2

Click on the "RUN" button to see it work.

Cheerio,
vcoolio.

 

[mumps]

Another option:

Sub CreateSheet()
    Application.ScreenUpdating = False
    Dim bottomB As Long
    bottomB = Sheets("MasterSheet").Range("B" & Rows.Count).End(xlUp).Row
    Dim rNum As Range
    Dim ws As Worksheet
    Dim rngUniques As Range
    Sheets("MasterSheet").Range("B1:B" & bottomB).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("B1:B" & bottomB), Unique:=True
    Set rngUniques = Sheets("MasterSheet").Range("B2:B" & bottomB).SpecialCells(xlCellTypeVisible)
    If Sheets("MasterSheet").AutoFilterMode = True Then Sheets("MasterSheet").AutoFilterMode = False
    For Each rNum In rngUniques
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(rNum.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Sheets("CustomerTemplate").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = rNum
        End If
    Next rNum
    For Each rNum In rngUniques
        Sheets(rNum.Value).Range("A7:G" & Sheets(rNum.Value).Range("A" & Sheets(rNum.Value).Rows.Count).End(xlUp).Row + 1).ClearContents
        With Sheets(rNum.Value)
            .Range("B3") = rNum
            .Range("B4") = Sheets("MasterSheet").Cells(rNum.Row, 3)
        End With
        Sheets("MasterSheet").Range("B1:B" & bottomB).AutoFilter Field:=1, Criteria1:=rNum
        Intersect(Sheets("MasterSheet").Rows("2:" & bottomB), Sheets("MasterSheet").Range("D:E,N:N")).Copy Sheets(rNum.Value).Cells(Sheets(rNum.Value).Rows.Count, "A").End(xlUp).Offset(1, 0)
        Intersect(Sheets("MasterSheet").Rows("2:" & bottomB), Sheets("MasterSheet").Range("T:T")).Copy Sheets(rNum.Value).Cells(Sheets(rNum.Value).Rows.Count, "D").End(xlUp).Offset(1, 0)
        Intersect(Sheets("MasterSheet").Rows("2:" & bottomB), Sheets("MasterSheet").Range("P:P")).Copy Sheets(rNum.Value).Cells(Sheets(rNum.Value).Rows.Count, "E").End(xlUp).Offset(1, 0)
        Intersect(Sheets("MasterSheet").Rows("2:" & bottomB), Sheets("MasterSheet").Range("K:K,L:L")).Copy Sheets(rNum.Value).Cells(Sheets(rNum.Value).Rows.Count, "F").End(xlUp).Offset(1, 0)
        If Sheets("MasterSheet").AutoFilterMode = True Then Sheets("MasterSheet").AutoFilterMode = False
    Next rNum
    Application.ScreenUpdating = True
 End Sub

Each time you run this macro, it clears all the data in the new sheets and refreshes each new sheet with any data that you may have added to the MasterSheet since it was last run.