Separating a Workbook into Multiple Worksheets

dhauser

New Member
Joined
Mar 14, 2011
Messages
8
Hello,

Thank you in advanced for taking the time to read this post. I would like to separate a workbook into multiple worksheets based upon the information in a single column. For example, I have customers and customer information in a single workbook organized by country. How can I separate all of the customers and corresponding customer information by country into separate worksheets?

To better illustrate this example, suppose I would like all of the customers (and their corresponding information) in Japan separated into a "Japan" worksheet and all of the customers in the UK separated into a "UK" worksheet. Is there a way to do this?

Have a rad day!

Dan
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

texasalynn

Well-known Member
Joined
May 19, 2002
Messages
8,458
welcome to MrExcel board...

this macro will separate with the data in column A
Code:
Sub breakout()
Workbooks(1).Activate
Dim LastCol As Integer, LastRow As Long, x As Long
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim SheetNameArray, fn As WorksheetFunction
Dim CalcSetting As Integer
Dim newsht As Worksheet
Set fn = Application.WorksheetFunction
 
With Application
    CalcSetting = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
 
With Sheets("All")
    Set Rng = .UsedRange
    Set Rng1 = Intersect(Rng, .Range("A:A"))
    LastCol = Rng.Column + Rng.Columns.Count - 1
 
    .Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=.Cells(1, LastCol + 2), Unique:=True
 
    Set Rng2 = Intersect(.Columns(LastCol + 2).CurrentRegion, _
    .Rows("2:" & Rows.Count))
 
    ReDim SheetNameArray(1 To Rng2.Cells.Count)
    SheetNameArray = fn.Transpose(Rng2)
    .Columns(LastCol + 2).Clear
 
    For x = LBound(SheetNameArray) To UBound(SheetNameArray)
        On Error Resume Next
        Set newsht = ThisWorkbook.Sheets(CStr(SheetNameArray(x)))
            If Err <> 0 Then
                Worksheets.Add
                ActiveSheet.Name = CStr(SheetNameArray(x))
                Err.Clear
            End If
        On Error GoTo 0
            Rng.AutoFilter Field:=1, Criteria1:=SheetNameArray(x)
            Set Rng3 = Intersect(Rng, .Cells.SpecialCells(xlCellTypeVisible))
            Rng3.Copy Workbooks(1).Sheets(CStr(SheetNameArray(x))).Range("A1")
            Rng.AutoFilter
     Next x
End With
Range("A1").Select
Application.Calculation = CalcSetting
 
End Sub
<!-- / message --><!-- sig -->
 

dhauser

New Member
Joined
Mar 14, 2011
Messages
8
Hello Texaslynn,

Thank you very much for the info! I look forward to trying this out.

Take care!

Dan
 

kolle_hond

New Member
Joined
Mar 4, 2011
Messages
8
I haven't tested this yet but it might lead you in the right direction

Code:
Private Sub CommandButton1_Click()
'new worksheet variable (optional but easier to change elements directly)
Dim newsheet As Worksheet

'counter for rows
Dim icount As Integer

'number of rows
Dim irows

icount = 1

    Do While Sheet1.Range("A" & icount) <> 0 'assuming column A is where the country field is written
    
        'create new sheet if it doesn't exist
        If ActiveWorkbook.Worksheets(Sheet1.Range("A" & icount)) = 0 Then
            
            newsheet = ActiveWorkbook.Worksheets.Add
                With newsheet
                    'make the name the country
                    .Name = Sheet1.Range("A" & icount)
                End With
        Else
        'assign sheet if it exists
            newsheet = ActiveWorkbook.Worksheets(Sheet1.Range("A" & icount))
        End If
        'check the number of fields
        irows = newsheet.Range("A").CountA(Sheet1.Range("A" & icount))

        'copy row from first sheet
        Sheet1.Rows(icount).Copy (newsheet.Rows(irows + 1))
        
        icount = icount + 1
        
    Loop

End Sub
 

dhauser

New Member
Joined
Mar 14, 2011
Messages
8
Hello,

Thanks again for the help... this is working great. I had to make one change to the code in order for it to work for me...

Sub breakout()<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
Workbooks(1).Activate<o:p></o:p>
Dim LastCol As Integer, LastRow As Long, x As Long<o:p></o:p>
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range<o:p></o:p>
Dim SheetNameArray, fn As WorksheetFunction<o:p></o:p>
Dim CalcSetting As Integer<o:p></o:p>
Dim newsht As Worksheet<o:p></o:p>
Set fn = Application.WorksheetFunction<o:p></o:p>
<o:p></o:p>
With Application<o:p></o:p>
CalcSetting = .Calculation<o:p></o:p>
.Calculation = xlCalculationManual<o:p></o:p>
.ScreenUpdating = False<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
With Sheets("All")<o:p></o:p>


I changed "With Sheets ("All")" to "With Activesheet".

Everything was fine from there.

Have a rad day!

Dan
 

Forum statistics

Threads
1,141,218
Messages
5,705,080
Members
421,377
Latest member
FerdiFuchs

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
Top