VBA Code to copy data based on criteria to tab with the same name

[VBAAccountant]

I have a file that summarizes all sales by a sales person ("Sales By Sales Person"). The sales person names are in Column D. There are tabs named for each of the sales people. I am trying (with no luck) to create a macro that will take all rows with that a sales person's name on the summary tab and then copy those rows to the tab with that person's name. Any suggestions? Thanks in advance.

 

[vcoolio]

Hello VBAAcc,

I'm not sure how your master sheet is set out, but here is a starting point for you:

Option Explicit

Sub Test()

              Dim i As Long, lr As Long
              Dim sh As Worksheet, wsD As Worksheet, ar As Variant
        
Application.ScreenUpdating = False
        
              Set sh = Sheets("Master") '---->Change sheet name to suit.
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("D1:D" & lr).AdvancedFilter 2, , sh.[Z1], 1  'Unique values moved temporarily to Column Z.
              sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)).Sort [Z2], 1 'Unique values sorted.
              ar = sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)) 'Unique values placed in an array.
              
       For i = 1 To UBound(ar)
                    
              Set wsD = Sheets(CStr(ar(i, 1))) '---->Destination worksheets.
              wsD.UsedRange.Clear '---->The destination sheets are all cleared prior to each data transfer.
                    
              With sh.[A1].CurrentRegion
                   .AutoFilter 4, ar(i, 1)
                   .Copy wsD.[A1]
                   .AutoFilter
             End With
                   wsD.Columns.AutoFit
       Next i

             sh.Columns("Z").Clear 'Clear helper column to be used again as needed.
             
Application.Goto sh.[A1]
Application.ScreenUpdating = True

End Sub

I've added some comments to help you understand the code.

I hope that this helps.

Cheerio,
vcoolio.

 

[VBAAccountant]

Hello VBAAcc,

I'm not sure how your master sheet is set out, but here is a starting point for you:

Option Explicit

Sub Test()

              Dim i As Long, lr As Long
              Dim sh As Worksheet, wsD As Worksheet, ar As Variant
       
Application.ScreenUpdating = False
       
              Set sh = Sheets("Master") '---->Change sheet name to suit.
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("D1:D" & lr).AdvancedFilter 2, , sh.[Z1], 1  'Unique values moved temporarily to Column Z.
              sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)).Sort [Z2], 1 'Unique values sorted.
              ar = sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)) 'Unique values placed in an array.
             
       For i = 1 To UBound(ar)
                   
              Set wsD = Sheets(CStr(ar(i, 1))) '---->Destination worksheets.
              wsD.UsedRange.Clear '---->The destination sheets are all cleared prior to each data transfer.
                   
              With sh.[A1].CurrentRegion
                   .AutoFilter 4, ar(i, 1)
                   .Copy wsD.[A1]
                   .AutoFilter
             End With
                   wsD.Columns.AutoFit
       Next i

             sh.Columns("Z").Clear 'Clear helper column to be used again as needed.
            
Application.Goto sh.[A1]
Application.ScreenUpdating = True

End Sub

I've added some comments to help you understand the code.

I hope that this helps.

Cheerio,
vcoolio.

Thank you...worked perfectly!!!!

 

[vcoolio]

You're welcome. I'm glad to have been able to assist.

Cheerio,
vcoolio.