Link to home
Start Free TrialLog in
Avatar of RishiSingh05
RishiSingh05Flag for United States of America

asked on

Macro to create Excel tabs

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.
Avatar of Patrick Matthews
Patrick Matthews
Flag of United States of America image

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
Avatar of RishiSingh05

ASKER

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

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

Patrick
ok Patrick if you insist  ... as soon as I have a moment.  Thanks !
Avatar of wchh
wchh

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

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

Would this not impact Line 1 of your code?
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

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

ASKER CERTIFIED SOLUTION
Avatar of wchh
wchh

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Good job.   It does everything I wanted it to do, and in a split second.  Saves me a lot of time.  Thanks