asked on

In Excel, select specific rows from a list and place in separate worksheets

The original list contains 4 columns.
Column A contains an ID number for each row.
The ID number is common to several hundred rows.
In this file there are 15 different ID numbers, for about 12,700 rows. (See file named Original Address list.xlsx)
The requirement is for a macro to select the common ID numbers and places all rows in a separate worksheet, naming the worksheet with the ID number and the total of the rows in the worksheet. (See the file named Required Address list.xlsx)
Original-Address-list.xlsx
Required-Address-list.xlsx

Lohith GN

Hi. whats the version of Excel you are targeting ?

gregfthompson

ASKER

office 2013 version thanks,

Greg

Subodh Tiwari (Neeraj)

Hi Greg,

You may try something like this.
In the attached, click the button called "Create Individual Address Sheets" to run the code.

Sub CreateAddressSheets()
Dim sws As Worksheet, dws As Worksheet
Dim x, dict, it
Dim i As Long, cnt As Long
Application.ScreenUpdating = False

DeleteAllSheetsButOriginal
Set sws = Sheets("Original")
x = sws.Range("A1").CurrentRegion.Value

Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    With sws.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:=it
        cnt = .SpecialCells(xlCellTypeVisible).Rows.Count - 1
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = it & " " & cnt
        Set dws = ActiveSheet
        .SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
        dws.UsedRange.Columns.AutoFit
    End With
Next it
sws.AutoFilterMode = 0
sws.Activate
Application.ScreenUpdating = True
MsgBox "Individual Address Sheets have been created successfully.", vbInformation, "Done!"
End Sub

Sub DeleteAllSheetsButOriginal()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> "Original" Then
        ws.Delete
    End If
Next ws
End Sub

Open in new window

Original-Address-list.xlsm

gregfthompson

ASKER

Thanks Subodh Tiwari (Neeraj).

That worked - created the worksheets and included a total in the name for the first worksheet.
Can you adjust so that a total is also included for the other worksheets?

Thanks,

Greg

Subodh Tiwari (Neeraj)

I didn't notice that. My bad.

Please replace the existing code with the following one.

Sub CreateAddressSheets()
Dim sws As Worksheet, dws As Worksheet
Dim x, dict, it
Dim i As Long, cnt As Long
Application.ScreenUpdating = False

DeleteAllSheetsButOriginal
Set sws = Sheets("Original")
x = sws.Range("A1").CurrentRegion.Value

Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    With sws.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:=it
        Sheets.Add after:=Sheets(Sheets.Count)
        Set dws = ActiveSheet
        .SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
        cnt = dws.UsedRange.Rows.Count - 1
        dws.Name = it & " " & cnt
        dws.UsedRange.Columns.AutoFit
        .AutoFilter
    End With
Next it
sws.Activate
Application.ScreenUpdating = True
MsgBox "Individual Address Sheets have been created successfully.", vbInformation, "Done!"
End Sub

Sub DeleteAllSheetsButOriginal()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> "Original" Then
        ws.Delete
    End If
Next ws
End Sub

Open in new window

gregfthompson

ASKER

Not really bad, yet!

The amended code still will not include totals on the rest of the worksheets.

Thanks,

Greg

ASKER CERTIFIED SOLUTION

Subodh Tiwari (Neeraj)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

gregfthompson

ASKER