Splitting a file into multiple files as per a column

Hi,

is there anyway of making a macro that when run it splits the main workbook into several workbooks as per a column in the main workbook.

eg:

Column A has only 10 differing entries. Each of the 250 lines of the workbook has one of those 10 values in column A. I am trying to split the file into 10 seperate files for each one of those values. sorry, its quite hard to explain.

imagine my column A is: (+ there is data all the way up to column AD)

a
b
b
a
c
a
b

i want to create a macro that will split this into a file of all the a's, a file of all the b's and a file of all the c's

Now i could record a macro where i do this manually but was wondering if theres a quicker way?

Thank you in advance

Like this? Assumes you have headers in row 1, and you need to change the path.

Sub x()
 
Dim r As Long, rng As Range, ws As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Sheets("Sheet1")
    Sheets.Add().Name = "temp"
    .Range("A1", .Range("A" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True
     For Each rng In Sheets("temp").Range("A2", Sheets("temp").Range("A2").End(xlDown))
        .AutoFilterMode = False
        .Range("A1").AutoFilter field:=1, Criteria1:=rng
        Set ws = Sheets.Add
        .AutoFilter.Range.Copy ws.Range("A1")
        ws.Name = rng
        ws.Move
        ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\" & rng & ".xls"
    Next rng
    .AutoFilterMode = False
    Sheets("temp").Delete
End With
     
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub tst()
  With sheet1.UsedRange.Columns(1)
    sq = .Value
    
    For j = 1 To UBound(sq)
      If InStr(c01 & "|", "|" & sq(j, 1) & "|") = 0 Then
        c01 = c01 & "|" & sq(j, 1)
        .Replace sq(j, 1), "", xlWhole
        .SpecialCells(4).EntireRow.Copy Sheet.Cells(1, 1)
        With Sheet2
          .Cells(1, 2).CurrentRegion.Resize(, 1).Offset(, -1) = sq(j, 1)
          .Copy
          .Cells.ClearContents
        End With
        With ActiveWorkbook
          .SaveAs sq(j, 1) & ".xls"
          .Close False
        End With
        .Value = sq
      End If
    Next
  End With
End Sub

Originally Posted by StephenR

Like this? Assumes you have headers in row 1, and you need to change the path.

Sub x()
 
Dim r As Long, rng As Range, ws As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Sheets("Sheet1")
    Sheets.Add().Name = "temp"
    .Range("A1", .Range("A" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("temp").Range("A1"), Unique:=True
     For Each rng In Sheets("temp").Range("A2", Sheets("temp").Range("A2").End(xlDown))
        .AutoFilterMode = False
        .Range("A1").AutoFilter field:=1, Criteria1:=rng
        Set ws = Sheets.Add
        .AutoFilter.Range.Copy ws.Range("A1")
        ws.Name = rng
        ws.Move
        ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\" & rng & ".xls"
    Next rng
    .AutoFilterMode = False
    Sheets("temp").Delete
End With
     
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Great reply! Worked perfect -Thank you!

Hi- Sorry forgot to mention I use Excel 2010 - thanks!