Create new spreadsheets for like items in a column

[rthorne]

Hi guru's....... I have a spreadsheet that has over 80 codes in column A. (i.e.)

A001
A002
A003
A030
A049

From this master file, I need to create individual spreadsheet for each code. There may be thousands with code A049, or hundresds with code A001. I have been filtering for each one, copied on visible cells, then pasting into a new worksheet. Is there a more simplified or VBA code to do this?

Thanks, rthorne

 

[Norie]

Try this, it creates new worksheets but can be adapted to create new workbooks for each code.

Option Explicit
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
 
    Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
 
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
 
    Set wsCrit = Worksheets.Add
 
    ' column A has the criteria eg code    wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
 
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
 
    For I = 2 To LastRowCrit
 
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
 
    Next I
 
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
 
End Sub