Splitting Data into Separate Worksheets

irksy

New Member
Joined
Jul 10, 2013
Messages
29
Hi. Please bear with me as I only used my first VBA yesterday and now I am looking to use them for everything!! :laugh:<!--[if gte vml 1]><v:shapetype id="_x0000_t75" coordsize="21600,21600" o:spt="75" o:preferrelative="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> <v:path 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:p></o:p>
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:p></o:p>
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:p></o:p>
Making sense so far??<o:p></o:p>
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:p></o:p>
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!!!
 
Last edited:

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
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.
Code:
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
 
Upvote 0
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.
 
Upvote 0
Maybe try:

Code:
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
 
Upvote 0

Forum statistics

Threads
1,224,825
Messages
6,181,189
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top