Splitting Data into Separate Worksheets

[irksy]

Hi. Please bear with me as I only used my first VBA yesterday and now I am looking to use them for everything!! <!--[if gte vml 1]><v:shapetype id="_x0000_t75" coordsize="21600,21600" o:spt="75" oreferrelative="t" path="m@4@5l@4@11@9@11@9@5xe" filled="f" stroked="f"> <v:stroke joinstyle="miter"/> <v:formulas> <v:f eqn="if lineDrawn pixelLineWidth 0"/> <v:f eqn="sum @0 1 0"/> <v:f eqn="sum 0 0 @1"/> <v:f eqn="prod @2 1 2"/> <v:f eqn="prod @3 21600 pixelWidth"/> <v:f eqn="prod @3 21600 pixelHeight"/> <v:f eqn="sum @0 0 1"/> <v:f eqn="prod @6 1 2"/> <v:f eqn="prod @7 21600 pixelWidth"/> <v:f eqn="sum @8 21600 0"/> <v:f eqn="prod @7 21600 pixelHeight"/> <v:f eqn="sum @10 21600 0"/> </v:formulas> <vath o:extrusionok="f" gradientshapeok="t" o:connecttype="rect"/> <o:lock v:ext="edit" aspectratio="t"/></v:shapetype><v:shape id="Picture_x0020_1" o:spid="_x0000_i1025" type="#_x0000_t75" alt="http://www.mrexcel.com/forum/images/smilies/icon_laugh.gif" style='width:11.25pt; height:11.25pt;visibility:visible;mso-wrap-style:square'> <v:imagedata src="file:///C:\Users\smithd\AppData\Local\Temp\msohtmlclip1\01\clip_image001.gif" o:title="icon_laugh"/></v:shape><![endif]--><!--[if !vml]--><!--[endif]--> <o></o>
I regularly get sent a spreadsheet containing around20000 rows of data and wish to separate all of this data by company name. My normal process with the spreadsheet was to sort it by company name then separate each one onto its own worksheet, then move/copy the tab to a separate workbook and save it as the company name. That's a nice easy job if there is only a few tabs to work. My last file ended up with 129 tabs so I sought help and found a VBA which then saved each worksheet as a separate workbook with the relevant name. I want to take this one step further and split the original workbook into separate workbooks without the need to manually copy the data onto individual worksheets. <o></o>
I do on occasion use pivot tables, but in this case I need the data on a workbook to send out in the same format I receive it.<o></o>
Making sense so far??<o></o>
I have uploaded a sample of the workbook as I receive it and highlighted the column I need the sheet splitting by. http://sdrv.ms/12YhJ8Q<o></o>
Any help would be greatly received! !
I would also like to add I have searched and found a few similar posts but could not get the advice posted on those queries to work with my situation. Probably just me being daft but like I said still new at this!!

Thanks!!!

 

[mirabeau]

irksy,

is this vba code of any interest to you? It creates new sheets but doesn't check if sheet of that name already exists.

Sub miscreant()
Const cl& = 18
Const basesh = "Sheet1"
Dim a As Variant, q As Variant
Dim rws&, cls&, p&, i&, b As Boolean
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(basesh))
    Sheets(basesh).Cells(1).CurrentRegion.Copy .Cells(1)
    Set a = .Cells(1).CurrentRegion
    rws = a.Rows.Count
    cls = a.Columns.Count
    a.Sort a(1, cl), Header:=xlYes
    .Name = a(2, cl)
    a = a.Resize(rws + 1)
    p = 2
    For i = p To rws + 1
        If a(i, cl) <> a(p, cl) Then
            If b Then
                Sheets.Add.Name = a(p, cl)
                .Cells(p, 1).Resize(i - p, cls).Cut Cells(2, 1)
                Sheets(basesh).Cells(1).Resize(, cls).Copy Cells(1)
            End If
            b = True
            p = i
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[Andrew Poulsom]

Maybe this will help you:

http://www.mrexcel.com/forum/excel-questions/233014-copying-data-one-table-many.html

 

[irksy]

Mirabeu - Thank you for your response, unfortunately I cannot get the process to run.

Andrew - Thanks for you link, I have looked at the posted module and due to being a complete newbie when it comes to this level of excel, I am unsure how to edit it to enable it to work with my spreadsheet.

 

[Andrew Poulsom]

Maybe try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim WB As Workbook
    Application.ScreenUpdating = False
''   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("R2:R" & Sh.Range("R" & Sh.Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:S" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    For Each Item In List
        Set WB = Workbooks.Add
        Rng.AutoFilter Field:=18, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
        Rng.AutoFilter
        With WB
            .SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
            .Close
        End With
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

 

[irksy]

Excellent, Thank you for all your help Andrew!