Macro to create Excel tabs

RishiSingh05
RishiSingh05 used Ask the Experts™
on
My Excel spreadsheet has data in columns A to BE and is sorted in ascending order on Col W: WBI_HLR_ID

I would like a macro which, for every change in WBI_HLR_ID, will copy all rows with the same WBI_HLR_ID to a separate tab.  Thanks.
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2010

Commented:
RishiSingh05,

It would be useful to see some sample data and/or a sample file.  EE now allows you to directly upload files to your question.

Please be advised that once you upload a file, it can be publicly accessed, and that it may not be possible to fully and permanently delete it.  The file may also be indexed by the major search engines.

Therefore, be very careful about posting proprietary, confidential, or other sensitive information.  If necessary, use "fake" and/or obfuscated data in your sample.

Please note that at present EE restricts uploads to certain file types.  If your file type does not match those in the list, you can use http://www.ee-stuff.com instead, which is not officially an EE site, but is run by people connected to EE.

Patrick

Author

Commented:
The ID's in Col W are purely numeric data (sorted in ascending sequence).  I cannot post sample date.  Thanks.

Author

Commented:
"sample data"
Build an E-Commerce Site with Angular 5

Learn how to build an E-Commerce site with Angular 5, a JavaScript framework used by developers to build web, desktop, and mobile applications.

Top Expert 2010

Commented:
RishiSingh05,

Of course you can post sample data.  It doesn't have to be real; fake data will do.

Patrick

Author

Commented:
ok Patrick if you insist  ... as soon as I have a moment.  Thanks !

Commented:
Try Macro Below
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim MaxCnt As Long
 MaxCnt = ActiveSheet.UsedRange.Rows.Count
 If Not Intersect(Target, Range("W2:W" & MaxCnt)) Is Nothing Then
    shtsrc = ActiveSheet.Name
    Application.ScreenUpdating = False

    With Worksheets(shtsrc)
        .Range("A1:BE" & MaxCnt).AutoFilter Field:=23, Criteria1:=Target.Value
        Set rngToCopy = Nothing
        Set rngToCopy = .Range("A2:BE" & MaxCnt).SpecialCells(xlCellTypeVisible)
        Sheets.Add
        If Not rngToCopy Is Nothing Then rngToCopy.Copy ActiveSheet.Range("A1")
        .ShowAllData
        .Range("A1:BE" & MaxCnt).AutoFilter
    End With
    Application.ScreenUpdating = True
 End If

End Sub

Open in new window

Author

Commented:
wchh: Excel expects a name for the macro.  For example, sub automate2 ()

Would this not impact Line 1 of your code?

Author

Commented:
I made a small change to your code but got an error on Line 5 "invalid procedure call or argument":


Sub automate2()
Dim Target As Range
 Dim MaxCnt As Long
 MaxCnt = ActiveSheet.UsedRange.Rows.Count
 If Not Intersect(Target, Range("W2:W" & MaxCnt)) Is Nothing Then
    shtsrc = ActiveSheet.Name
    Application.ScreenUpdating = False

    With Worksheets(shtsrc)
        .Range("A1:BY" & MaxCnt).AutoFilter Field:=23, Criteria1:=Target.Value
        Set rngToCopy = Nothing
        Set rngToCopy = .Range("A2:BY" & MaxCnt).SpecialCells(xlCellTypeVisible)
        Sheets.Add
        If Not rngToCopy Is Nothing Then rngToCopy.Copy ActiveSheet.Range("A1")
        .ShowAllData
        .Range("A1:BY" & MaxCnt).AutoFilter
    End With
    Application.ScreenUpdating = True
 End If

End Sub

Open in new window

Commented:
if you use macro to copy tab, please refer to below
Sub Move_tab()

 Set Rng = ActiveSheet.Range("W2:W" & ActiveSheet.UsedRange.Rows.Count)
 Set RngHd = ActiveSheet.Rows(1)
 Application.ScreenUpdating = False
 For Each cel In Rng
     If Not SheetExists(cel.Value) Then
        Worksheets.Add.Name = cel.Value
        RngHd.Copy Worksheets("" & cel.Value & "").Range("A1")
        cel.EntireRow.Copy Worksheets("" & cel.Value & "").Range("A2")
     Else
     cel.EntireRow.Copy Worksheets("" & cel.Value & "").Range("A" & Worksheets("" & cel.Value & "").UsedRange.Rows.Count + 1)
     End If
     
 Next cel
 Application.ScreenUpdating = True
End Sub

Open in new window

Commented:
Please also include function sheetexists
Sub Move_tab()

 Set Rng = ActiveSheet.Range("W2:W" & ActiveSheet.UsedRange.Rows.Count)
 Set RngHd = ActiveSheet.Rows(1)
 Application.ScreenUpdating = False
 For Each cel In Rng
     If Not SheetExists(cel.Value) Then
        Worksheets.Add.Name = cel.Value
        RngHd.Copy Worksheets("" & cel.Value & "").Range("A1")
        cel.EntireRow.Copy Worksheets("" & cel.Value & "").Range("A2")
     Else
     cel.EntireRow.Copy Worksheets("" & cel.Value & "").Range("A" & Worksheets("" & cel.Value & "").UsedRange.Rows.Count + 1)
     End If
     
 Next cel
 Application.ScreenUpdating = True
End Sub

Function SheetExists(strWSName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(strWSName)
    If Not ws Is Nothing Then SheetExists = True
End Function

Open in new window

Author

Commented:
Good job.   It does everything I wanted it to do, and in a split second.  Saves me a lot of time.  Thanks

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial