Create sheets from sheet based on value of column

[NMGMX]

I have a Workbook with a sheet w/ rows that extend out to about column AT. Column B is the "Category" column. I want to have a macro that copies and splits the rows in each category into different sheets, each sheet title with the the category name, but still keep all the rows together in the original sheet.

 

[hiker95]

NMGMX,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


Can you post a screenshot of the actual raw data worksheet?

And, can you post a screenshot of the worksheet results (manually formatted by you) that you are looking for?

To post your data, you can download and install one of the following two programs:
1. MrExcel HTMLMaker20101230
https://onedrive.live.com/?cid=8cffdec0ce27e813&sc=documents&id=8CFFDEC0CE27E813!189

Installation instructions here:
http://www.mrexcel.com/forum/board-announcements/515787-forum-posting-guidelines.html#post2545970

2. Excel Jeanie
Download



Because of the number of columns in your raw data worksheet, screenshots will probably not work.

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[JoeMo]

I have a Workbook with a sheet w/ rows that extend out to about column AT. Column B is the "Category" column. I want to have a macro that copies and splits the rows in each category into different sheets, each sheet title with the the category name, but still keep all the rows together in the original sheet.

This assumes your data in the source sheet are arranged in a table style with no empty rows or columns from A1:ATwhatever, that the source sheet is named Sheet1 (note comment in code where you can change this), and that none of your category names contains characters that Excel will not accept in a sheet name (like "/").

Sub MakeSheetsFromCategories()
'assume sheet with categories is Sheet1, categories start in B2
Dim sSht As Worksheet, tempSht As Worksheet, c As Range

Set sSht = Sheets("Sheet1")  'Source sheet - change name to suit
Application.ScreenUpdating = False
Set tempSht = Sheets.Add(before:=Sheets(1))
With sSht
    .Range("B1", sSht.Range("B2").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, _
        copytorange:=tempSht.Range("A1"), unique:=True
    For Each c In tempSht.Range("A2", tempSht.Range("A2").End(xlDown))
        Application.DisplayAlerts = False
        On Error Resume Next
        Sheets(c.Value).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = c.Value
        With .Range("B2").CurrentRegion
            .AutoFilter field:=2, Criteria1:=c.Value
            .Copy Destination:=ActiveSheet.Range("A1")
        End With
    Next c
End With
With sSht
    .ShowAllData
    .AutoFilterMode = False
    .Select
End With
Application.DisplayAlerts = False
tempSht.Delete
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

 

[hiker95]

NMGMX,

The following macro will adjust for a varying number of rows, and, columns,

Sample raw data in worksheet Sheet1 (before, and, after the macro) (not all columns are shown for brevity):

Excel 2007
	A	B	C	D	E	AS	AT
1	1	Category	3	4	5	45	46
2	1	1	1	1	1	1	1
3	2	2	2	2	2	2	2
4	3	3	3	3	3	3	3
5	4	4	4	4	4	4	4
6	5	1	5	5	5	5	5
7	6	2	6	6	6	6	6
8	7	3	7	7	7	7	7
9	8	4	8	8	8	8	8
10	9	1	9	9	9	9	9
11	10	2	10	10	10	10	10
12	11	3	11	11	11	11	11
13	12	4	12	12	12	12	12
14
Sheet1

After the macro in the new worksheets (not all columns are shown for brevity):

Excel 2007
	A	B	C	D	E	AS	AT
1	1	Category	3	4	5	45	46
2	1	1	1	1	1	1	1
3	5	1	5	5	5	5	5
4	9	1	9	9	9	9	9
5
1

Excel 2007
	A	B	C	D	E	AS	AT
1	1	Category	3	4	5	45	46
2	2	2	2	2	2	2	2
3	6	2	6	6	6	6	6
4	10	2	10	10	10	10	10
5
2

Excel 2007
	A	B	C	D	E	AS	AT
1	1	Category	3	4	5	45	46
2	3	3	3	3	3	3	3
3	7	3	7	7	7	7	7
4	11	3	11	11	11	11	11
5
3

Excel 2007
	A	B	C	D	E	AS	AT
1	1	Category	3	4	5	45	46
2	4	4	4	4	4	4	4
3	8	4	8	8	8	8	8
4	12	4	12	12	12	12	12
5
4

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub DistributeRows()
' hiker95, 07/19/2014, ME792724
Dim w1 As Worksheet, w As String
Dim oa As Variant
Dim r As Long, lr As Long, lc As Long, n As Long, nr As Long, lr2 As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  oa = .Range(.Cells(1, 1), .Cells(lr, lc))
  .Range(.Cells(2, 1), .Cells(lr, lc)).Sort key1:=.Range("B2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(2), .Cells(r, 2).Value)
    w = .Cells(r, 2)
    If Not Evaluate("ISREF('" & Trim(w) & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Trim(w)
    With Sheets(w)
      With .Cells(1, 1).Resize(, lc)
        .Value = w1.Cells(1, 1).Resize(, lc).Value
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
      End With
      lr2 = Sheets(w).Cells(Rows.Count, 1).End(xlUp).Row
      If lr2 > 2 Then Sheets(w).Range(.Cells(2, 1).Cells(lr2, lc)).ClearContents
      nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
      .Cells(nr, 1).Resize(n, lc).Value = w1.Cells(r, 1).Resize(n, lc).Value
      .Columns.AutoFit
    End With
    r = r + n - 1
  Next r
  .Range(.Cells(1, 1), .Cells(lr, lc)) = oa
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the DistributeRows macro.

 

[NMGMX]

Thank you for the answers. I found a code that works though. May try these later to see if they are faster. In the meantime can you guys look over at http://www.mrexcel.com/forum/excel-questions/792743-save-delete-extra-worksheets.html, this is where I'm currently having trouble.

 

[hiker95]

NMGMX,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.