VBA Code


Worksheet "Inventory Example" Tab "Sheet1"

Column A: 

Is there a way to run a macro with VBA code to create a tab for every different short description in Column A and label the tabs with:

1.10 Through 6.30

Want it to also copy and paste everything that corresponds across from that row in columns A:M

Thank you for all your help!



Selected Answer

The code below will execute the action you describe. Install it in a standard code module as was done in the attached sample workbook. I expect the code to be backward compatible to 2003 (meaning, it should work in a workbook of xls type) though it was written and tested using Excel 2013

Sub SortDataToSheets()
    ' 08 May 2019

    ' modify constants as required
    Const TabNameClm As Long = 1
    Const FirstDataRow As Long = 2                  ' caption row is required

    Dim Wb As Workbook                              ' the workbook in which the source data are found
    Dim WsS As Worksheet                            ' source data
    Dim Rng As Range
    Dim Cl As Long                                  ' last used data column
    Dim TabNames As Variant
    Dim Ws As Worksheet
    Dim R As Long
    Dim i As Integer

    Set Wb = ThisWorkbook                           ' change as required
    Set WsS = Wb.Worksheets("Sheet1")               ' modify sheet name as appropriate
    Application.ScreenUpdating = False

    With WsS
        With .UsedRange
            Cl = .Columns.Count + .Column
        End With
        ' filter for unique tab names
        Set Rng = .Range(.Cells(FirstDataRow, TabNameClm), .Cells(.Rows.Count, TabNameClm).End(xlUp))
        Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, Cl), Unique:=True

        Set Rng = .Range(.Cells(1, Cl), .Cells(.Rows.Count, Cl).End(xlUp))
        TabNames = Rng.Value
        Cl = Cl - 1

        Set Rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, TabNameClm).End(xlUp).Row, Cl))
        .Range(.Cells(1, 1), .Cells(1, Cl)).AutoFilter

        For i = LBound(TabNames) To UBound(TabNames)
            Application.StatusBar = "Processing " & TabNames(i, 1)
            On Error Resume Next
            Set Ws = Wb.Worksheets(TabNames(i, 1))  ' re-use existing sheet
            If Err Then
                ' create new sheet
                Set Ws = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
                Ws.Name = TabNames(i, 1)
            End If
            On Error GoTo 0

            Rng.AutoFilter Field:=TabNameClm, _
                           Criteria1:=TabNames(i, 1)
            Ws.Cells(1, 1).PasteSpecial
        Next i
    End With

    With Application
        .ScreenUpdating = True
        .StatusBar = "Done"
    End With
End Sub

After correct installation you will be able to call the macro from the 'Macros' button. There is a progress indicator in the Status Bar (at the bottom left of the screen).



Executes perfectly!

Only small thing is I tried changing "Sheet1" to "Master"and it errors out. No big deal jsut wondering why it won't allow that change.
Sroncey21 (rep: 62) May 8, '19 at 8:52 am
In theory the modification should be allowed. Therefore the question is why an error occurs. One should look at the type of error and where, in the code, it occurs. First place to look would be that "Master" doesn't exist in Wb. Consider the possibility of a space in the name, either in the workbook or the code, perhaps missing quotation marks around the name.
Variatus (rep: 4574) May 8, '19 at 8:17 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login