200+ Video Lessons
50+ Hours of Video
200+ Excel Guides
Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)
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!
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
.Columns(Cl).Delete
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)
Rng.SpecialCells(xlCellTypeVisible).Copy
Ws.Cells(1, 1).PasteSpecial
.ShowAllData
Next i
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End SubAfter 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).