loop through file creating seperate files depending on name in a column

Hi

i have file with approx 12,000 rows with columns A:I populated with data

in column G is a name

example rows 7:100 are rows for Tom Smith,

i need a macro that will loop through all 12,000, then create seperate excel files for each name

so first example would be one file with just tom smiths rows in it,
second file be the next person

is this atall possible?
thanks

See if this works for you.

If not, need to see your workbook.

Sub test()
    Dim e, x
    With ActiveSheet.Cells(1).CurrentRegion
        .Parent.AutoFilterMode = False
        Sheets.Add.Name = "temp"
        x = .Columns("g").Offset(1).Address
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & _
        ",,,row(1:" & .Rows.Count & "))," & x & ")=1," & x & ",char(2)))"), Chr(2), 0)
        For Each e In x
            .AutoFilter 7, e
            .Copy Sheets("temp").Cells(1)
            .AutoFilter
            Sheets("temp").Copy
            ActiveSheet.Name = e
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & e & ".xlsx"
            ActiveWorkbook.Close
            Sheets("temp").Cells.Clear
        Next
        Application.DisplayAlerts = False
        Sheets("temp").Delete
        Application.ScreenUpdating = True
    End With
End Sub

hi thanks for the reply!

on the attached, ive removed a lot of data so its just 200 lines, with 3 people - the end result being 3 seperate files by the 3 names in the file.

the actual main file will always be 11,0000 - 12,0000 rows with around 50 people

thanks

Sub test()
    Dim e, x
    Application.ScreenUpdating = False
    With Sheets("input").[b6].CurrentRegion
        .Parent.AutoFilterMode = False
        Sheets.Add.Name = "temp"
        x = .Columns("f").Offset(1).Address
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & _
        ",,,row(1:" & .Rows.Count & "))," & x & ")=1," & x & ",char(2)))"), Chr(2), 0)
        For Each e In x
            .AutoFilter 6, e
            .Copy Sheets("temp").Cells(1)
            .AutoFilter
            Sheets("temp").Copy
            ActiveSheet.Name = e
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & e & ".xlsx"
            ActiveWorkbook.Close
            Sheets("temp").Cells.Clear
        Next
        With Application
            .DisplayAlerts = False
            Sheets("temp").Delete
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With
    End With
End Sub

hi

i get an evalute error at this point

        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & x & _
        ",,,row(1:" & .Rows.Count & "))," & x & ")=1," & x & ",char(2)))"), Chr(2), 0)

thank you

Working for me...

hi works perfectly on 200 rows, but my master file is 12,000 rows and it seems to spit up an error on there? thanks

If you still get error then try this one.

Sub test()
    Dim a, e, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("input").[b6].CurrentRegion
        a = .Offset(1).Columns(6).Value
        .Parent.AutoFilterMode = False
        Sheets.Add.Name = "temp"
        For Each e In a
            If (e <> "") * (Not dic.exists(e)) Then
                dic(e) = Empty
                .AutoFilter 6, e
                .Copy Sheets("temp").Cells(1)
                .AutoFilter
                Sheets("temp").Copy
                ActiveSheet.Name = e
                ActiveWorkbook.SaveAs ThisWorkbook.Path & "/" & e & ".xlsx"
                ActiveWorkbook.Close
                Sheets("temp").Cells.Clear
            End If
        Next
        With Application
            .DisplayAlerts = False
            Sheets("temp").Delete
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With
    End With
End Sub

perfect thank you

You are welcome and thanks for the rep.

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

I will sneak this one in for posterity..

Used a couple of methods straight from snb's site.. as you can probably see..

Private Sub CommandButton1_Click()
    Dim a_sn, a_sp, X0, it, Z, c00, i As Long, ii As Long, cnt As Long
    Application.ScreenUpdating = False
    a_sn = Sheets("Input").Range("B7:G" & Range("B" & Rows.Count).End(xlUp).Row): cnt = 1
    With CreateObject("scripting.dictionary")
        For Each it In Application.Index(a_sn, 0, 6)
            X0 = .Item(a_sn(cnt, 6)): cnt = cnt + 1
        Next
        Z = .keys
    End With
    For i = LBound(Z) To UBound(Z)
        For ii = 1 To UBound(a_sn)
            If a_sn(ii, 6) = Z(i) Then c00 = c00 & "_" & ii
        Next ii
        a_sp = Application.Index(a_sn, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4, 5, 6))
        c00 = ""
        Workbooks.Add
        With ActiveWorkbook
            .Sheets("Sheet1").Range("A1").Resize(1, 6).Value = Array("Depot Name", "Drop Account Code", "Drop Account Description", "Unit Sales (net of VAT)", "Total Accrued", "Name")
            .Sheets("Sheet1").Range("A2").Resize(UBound(a_sp), 6).Value = a_sp
            .Sheets("Sheet1").Columns.AutoFit
            .SaveAs ThisWorkbook.Path & "\" & Z(i) & ".xls", FileFormat:=56
            .Close 1
        End With
    Next i
    Application.ScreenUpdating = True
End Sub