Split Sheet Data Into Smaller Sheets
Sub SplitTabInto2SheetsUsingFilterMarker()
'###############################################################################################################################################
'In this example, all 136k SKUs were downloaded using Store Manager, we want our Macros to run faster so we only want to use Relevant Data.
'Relevant Data in this case = Only SKUs where the the Supplier is either "Robert Allen" or "Duralee"
'Blank Column is inserted - Column A
'1)Supplier field is filtered by "Robert Allen", Mark Column A with an "X"
'2)Supplier field is filtered by "Duralee", Mark Column A with an "X"
'3)Run the macro
'When finished, consider moving (NOT Copy) tabs [StoreManager] and [UnusedStoreMgrData] to another book and archive to reduce file size of this book!
'###############################################################################################################################################
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iColReview As Long, iColCopy As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, aDump2() As Variant, iColDump As Long
Dim WsOther As Long, iNextRow1 As Long, iNextRow2 As Long, iColLoop As Long
Application.StatusBar = "Adding (or Updating) required Tabs used to split Store Manager data into 2 separate sheets."
'**********************************************************************
InsertTabRename ("UseStoreMgrData")
InsertTabRename ("UnusedStoreMgrData")
'**********************************************************************
Erase aData: Erase aDump: Erase aDump2
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Application.StatusBar = "Checking for Last Row & Last Column"
Ws1 = Worksheets("StoreManager").Index
'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
'Make sure that no rows are non-visible due to filtering:
If ActiveSheet.AutoFilterMode Then If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
iColReview = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: The filter to use should have already been created - based on Supplier.)", Title:="Specify Column by Clicking on ANY Cell.", Default:=Cells(1, 1).Address, Type:=8).Column
Ws2 = Worksheets("UseStoreMgrData").Index
WsOther = Worksheets("UnusedStoreMgrData").Index
iDumpColCount = iCe1
iColDump = iCe1 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iColReview = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Application.StatusBar = "Setting the Ranges for the Arrays"
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
aDump = Range(Worksheets(Ws1).Cells(1, iCe1 + 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1 + iDumpColCount).Address)
iNextRow1 = 1
aDump2 = Range(Worksheets(Ws1).Cells(1, iCe1 + 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1 + iDumpColCount).Address)
iNextRow2 = 1
'===================================================================================================
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aData)
'If non-blank filter, route to the Active Array load, otherwise, load in the Unused Array
If aData(iLoop, iColReview) <> "" Then GoTo gCopyRowDataToUsedArray
GoTo gCopyRowDataToUNusedArray
'++++++++++++++++++++++++++++++++++++++++++++
gCopyRowDataToUsedArray:
iNextRow1 = iNextRow1 + 1
For iColLoop = 1 To iCe1
aDump(iNextRow1, iColLoop) = aData(iLoop, iColLoop)
Next iColLoop
GoTo gMoveToNextLoop
'++++++++++++++++++++++++++++++++++++++++++++
'--------------------------------------------
gCopyRowDataToUNusedArray:
iNextRow2 = iNextRow2 + 1
For iColLoop = 1 To iCe1
aDump2(iNextRow2, iColLoop) = aData(iLoop, iColLoop)
Next iColLoop
GoTo gMoveToNextLoop
'--------------------------------------------
gMoveToNextLoop:
Next iLoop
'===================================================================================================
'===================================================================================================
'Update header for Dump column (x1)
Application.StatusBar = "Adding HEADERS to Both Arrays"
For iColLoop = 1 To iCe1
aDump(1, iColLoop) = aData(1, iColLoop)
aDump2(1, iColLoop) = aData(1, iColLoop)
Next iColLoop
'===================================================================================================
'===================================================================================================
'Dump Results (Used):
Application.StatusBar = "Dumping the Array of ACTIVE Store Manager Data, then deleting the extra blank rows at the end."
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Delete the extra rows
Range(Cells(iNextRow1 + 1, 1), Cells(iRe1, 1)).EntireRow.Delete Shift:=xlUp
'===================================================================================================
'Dump Results (UNused):
Application.StatusBar = "Dumping the Array of Unused Store Manager Data, then deleting the extra blank rows at the end."
Worksheets(WsOther).Select
Set Destination = Range(Worksheets(WsOther).Cells(1, 1).Address)
Destination.Resize(UBound(aDump2, 1), UBound(aDump2, 2)).Value = aDump2
'Delete the extra rows
Range(Cells(iNextRow2 + 1, 1), Cells(iRe1, 1)).EntireRow.Delete Shift:=xlUp
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aDump2
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub
'###############################################################################################################################################
'In this example, all 136k SKUs were downloaded using Store Manager, we want our Macros to run faster so we only want to use Relevant Data.
'Relevant Data in this case = Only SKUs where the the Supplier is either "Robert Allen" or "Duralee"
'Blank Column is inserted - Column A
'1)Supplier field is filtered by "Robert Allen", Mark Column A with an "X"
'2)Supplier field is filtered by "Duralee", Mark Column A with an "X"
'3)Run the macro
'When finished, consider moving (NOT Copy) tabs [StoreManager] and [UnusedStoreMgrData] to another book and archive to reduce file size of this book!
'###############################################################################################################################################
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iColReview As Long, iColCopy As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, aDump2() As Variant, iColDump As Long
Dim WsOther As Long, iNextRow1 As Long, iNextRow2 As Long, iColLoop As Long
Application.StatusBar = "Adding (or Updating) required Tabs used to split Store Manager data into 2 separate sheets."
'**********************************************************************
InsertTabRename ("UseStoreMgrData")
InsertTabRename ("UnusedStoreMgrData")
'**********************************************************************
Erase aData: Erase aDump: Erase aDump2
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Application.StatusBar = "Checking for Last Row & Last Column"
Ws1 = Worksheets("StoreManager").Index
'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
'Make sure that no rows are non-visible due to filtering:
If ActiveSheet.AutoFilterMode Then If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
iColReview = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: The filter to use should have already been created - based on Supplier.)", Title:="Specify Column by Clicking on ANY Cell.", Default:=Cells(1, 1).Address, Type:=8).Column
Ws2 = Worksheets("UseStoreMgrData").Index
WsOther = Worksheets("UnusedStoreMgrData").Index
iDumpColCount = iCe1
iColDump = iCe1 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iColReview = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Application.StatusBar = "Setting the Ranges for the Arrays"
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
aDump = Range(Worksheets(Ws1).Cells(1, iCe1 + 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1 + iDumpColCount).Address)
iNextRow1 = 1
aDump2 = Range(Worksheets(Ws1).Cells(1, iCe1 + 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1 + iDumpColCount).Address)
iNextRow2 = 1
'===================================================================================================
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aData)
'If non-blank filter, route to the Active Array load, otherwise, load in the Unused Array
If aData(iLoop, iColReview) <> "" Then GoTo gCopyRowDataToUsedArray
GoTo gCopyRowDataToUNusedArray
'++++++++++++++++++++++++++++++++++++++++++++
gCopyRowDataToUsedArray:
iNextRow1 = iNextRow1 + 1
For iColLoop = 1 To iCe1
aDump(iNextRow1, iColLoop) = aData(iLoop, iColLoop)
Next iColLoop
GoTo gMoveToNextLoop
'++++++++++++++++++++++++++++++++++++++++++++
'--------------------------------------------
gCopyRowDataToUNusedArray:
iNextRow2 = iNextRow2 + 1
For iColLoop = 1 To iCe1
aDump2(iNextRow2, iColLoop) = aData(iLoop, iColLoop)
Next iColLoop
GoTo gMoveToNextLoop
'--------------------------------------------
gMoveToNextLoop:
Next iLoop
'===================================================================================================
'===================================================================================================
'Update header for Dump column (x1)
Application.StatusBar = "Adding HEADERS to Both Arrays"
For iColLoop = 1 To iCe1
aDump(1, iColLoop) = aData(1, iColLoop)
aDump2(1, iColLoop) = aData(1, iColLoop)
Next iColLoop
'===================================================================================================
'===================================================================================================
'Dump Results (Used):
Application.StatusBar = "Dumping the Array of ACTIVE Store Manager Data, then deleting the extra blank rows at the end."
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Delete the extra rows
Range(Cells(iNextRow1 + 1, 1), Cells(iRe1, 1)).EntireRow.Delete Shift:=xlUp
'===================================================================================================
'Dump Results (UNused):
Application.StatusBar = "Dumping the Array of Unused Store Manager Data, then deleting the extra blank rows at the end."
Worksheets(WsOther).Select
Set Destination = Range(Worksheets(WsOther).Cells(1, 1).Address)
Destination.Resize(UBound(aDump2, 1), UBound(aDump2, 2)).Value = aDump2
'Delete the extra rows
Range(Cells(iNextRow2 + 1, 1), Cells(iRe1, 1)).EntireRow.Delete Shift:=xlUp
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aDump2
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub