Separating a Workbook into Multiple Worksheets

[dhauser]

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

 

[texasalynn]

welcome to MrExcel board...

this macro will separate with the data in column A

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]

Hello Texaslynn,

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

Take care!

Dan

 

[kolle_hond]

I haven't tested this yet but it might lead you in the right direction

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]

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-comfficeffice" /><o></o>
Workbooks(1).Activate<o></o>
Dim LastCol As Integer, LastRow As Long, x As Long<o></o>
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range<o></o>
Dim SheetNameArray, fn As WorksheetFunction<o></o>
Dim CalcSetting As Integer<o></o>
Dim newsht As Worksheet<o></o>
Set fn = Application.WorksheetFunction<o></o>
<o></o>
With Application<o></o>
CalcSetting = .Calculation<o></o>
.Calculation = xlCalculationManual<o></o>
.ScreenUpdating = False<o></o>
End With<o></o>
<o></o>
With Sheets("All")<o></o>


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

Everything was fine from there.

Have a rad day!

Dan