I have an excel file serving as a database with two worksheets, each with a table. Both tables have column A (Region) in common. Every Monday I must split this data, which has a few thousand lines, by Region, so I end up with about 30 files, each with the two sheets mentioned above, filtered for the respective region.
This is clearly inefficient, so I want to automate this process. At the moment I was able to come up with a macro that does automatically split the data, however only for the 1st worksheet, I am not being able to incorporate the data in the 2nd sheet as well.
Below is my current code working for splitting the data by the values in column A (Region) only in the 1st sheet:
Sub Split_Files()
Const aibPrompt As String = "Which column would you like to filter by?"
Const aibtitle As String = "Filter Column"
Const aibDefault As Long = 1
Dim dFileExtension As String: dFileExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim dFolderPath As String: dFolderPath = "XYZ"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
Application.ScreenUpdating = False
Dim sCol As Variant
sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
If sCol = False Then Exit Sub ' canceled
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 3 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
Dim scrg As Range: Set scrg = srg.Columns(sCol)
Dim scData As Variant: scData = scrg.Value
' Write the unique values from the 1st column to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
Dim Key As Variant
Dim r As Long
For r = 2 To srCount
Key = scData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Erase scData
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfcell As Range
Dim dFilePath As String
For Each Key In dict.Keys
' Add a new (destination) workbook and reference the first cell.
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
Set dfcell = dws.Range("A1")
' Copy/Paste
srrg.Copy
dfcell.PasteSpecial xlPasteColumnWidths
srg.AutoFilter sCol, Key
srg.SpecialCells(xlCellTypeVisible).Copy dfcell
sws.ShowAllData
dfcell.Select
' Save/Close
dFilePath = dFolderPath & "Access Rights Review " & Key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next Key
sws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub
How can I incorporate the 2nd worksheet table to be also split and added to the file of each region?
CodePudding user response：
Try this out - similar to your existing code but uses a Collection to hold the source worksheets.
Sub Split_Files()
Const dFileExtension As String = ".xlsx" 'include "."
Const dFolderPath As String = "C:\Temp\" 'include ending "\"
Dim dict As Object, wsNum As Long, dws As Worksheet, sws As Worksheet, srg As Range
Dim colWs As New Collection, ws As Worksheet, splitCol As Variant, fileExt
Dim dwb As Workbook, dfcell As Range, dFilePath As String, folderpath, key
'add the sheets to be split up
colWs.Add ThisWorkbook.Worksheets("Sheet1")
colWs.Add ThisWorkbook.Worksheets("Sheet2")
splitCol = Application.InputBox("Which column would you like to filter by?", _
"Filter Column", 1, , , , , 1)
If Len(Trim(splitCol)) = 0 Then Exit Sub ' no entry
If Not IsNumeric(splitCol) Then Exit Sub
splitCol = CLng(splitCol) 'convert to number
'collect unique values from the sheets to be split
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare ' case insensitive
For Each sws In colWs
If sws.FilterMode Then ws.ShowAllData
Set dict = UniqueColumnValues(sws.Cells(2, splitCol), dict)
Next sws
If dict.Count = 0 Then Exit Sub ' only error values and blanks
Application.ScreenUpdating = False
For Each key In dict.Keys
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
wsNum = 0 'reset destination sheet index
For Each sws In colWs
wsNum = wsNum 1
If wsNum > dwb.Worksheets.Count Then dwb.Worksheets.Add after:=dws
Set dws = dwb.Worksheets(wsNum)
dws.Name = sws.Name
Set srg = sws.Range("A1").CurrentRegion
srg.Rows(1).Copy
dws.Range("A1").PasteSpecial xlPasteColumnWidths
If srg.Rows.Count > 3 Then
srg.AutoFilter splitCol, key
srg.SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
sws.ShowAllData
End If
Next sws
dFilePath = dFolderPath & "Access Rights Review " & key & dFileExtension ' build the file path
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next key
Application.ScreenUpdating = True
MsgBox "Data exported.", vbInformation
End Sub
'Collect unique values in column, starting at `startCell` until last occupied cell
' in that column. Optionally append those values into a supplied dictionary object.
Function UniqueColumnValues(startCell As Range, Optional dict As Object = Nothing)
Dim c As Range, arr, r As Long, v
If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
With startCell.Worksheet
'read all values to an array (faster than cell-by-cell looping)
arr = .Range(startCell, .Cells(Rows.Count, startCell.Column).End(xlUp)).Value
End With
For r = 1 To UBound(arr, 1)
v = arr(r, 1)
If Not IsError(v) Then
If Len(v) > 0 Then
dict(v) = True
End If 'not blank
End If 'not an error
Next r
Set UniqueColumnValues = dict
End Function