Split one table into multiple sheets based on criteria

Some videos you may like

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,825
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback
 

Kyosti

Board Regular
Joined
Jun 2, 2008
Messages
84
@Fluff, You helped me before I hope you can help me again. I have listed below the macro as it stands today. Is there anyway that the macro after splitting the tabs out, can create its own individual file based on the tab name?

Sub VendorSplit()
'
' VendorSplit Macro
'
Dim Cl As Range
Dim WS As Worksheet
Dim Ky As Variant

Columns("E:E").Select
Selection.Replace What:="FULL ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="TPP", Replacement:="TRANSFER", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select

Set WS = Sheets("Data")
With CreateObject("scripting.dictionary")
For Each Cl In WS.Range("O2", WS.Range("O" & Rows.Count).End(xlUp))
.Item(Cl.Value) = Empty
Next Cl
For Each Ky In .Keys
WS.Range("A1:O1").AutoFilter 15, Ky
Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
WS.AutoFilter.Range.SpecialCells(xlVisible).EntireRow.Copy Range("A1")
Next Ky

Dim Wsht As Worksheet
For Each Wsht In Worksheets
With Wsht.UsedRange
.EntireColumn.AutoFit
End With
Next Wsht

Range("A1").Select
Sheets("Data").Select
Range("DataTable[[#Headers],[Original Producer Number]]").Select
ActiveSheet.ListObjects("DataTable").Range.AutoFilter Field:=15
ActiveWindow.SmallScroll Down:=-30

Cells.Select
Selection.ColumnWidth = 14
Range("DataTable[[#Headers],[Original Producer Number]]").Select

For i = 1 To Application.Sheets.Count
For j = 1 To Application.Sheets.Count - 1
If UCase$(Application.Sheets(j).Name) > UCase$(Application.Sheets(j + 1).Name) Then
Sheets(j).Move after:=Sheets(j + 1)

Sheets("Data").Select
Sheets("Data").Move Before:=Sheets(1)

End If
Next
Next
End With
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,825
Office Version
365
Platform
Windows
As this is now a totally different question, please start a new thread.
Thanks
 

Watch MrExcel Video

Forum statistics

Threads
1,089,892
Messages
5,411,064
Members
403,339
Latest member
kevin wilde

This Week's Hot Topics

Top