Hi All,
Hope everyone is well, I have been given a macro file to Split documents based on a Key in column A, this works perfect for where there is only one sheet to split. However if there is more than one sheet within the file to split it only does the 1st sheet and ignores the rest. Is there a way to amend this code to run across multiple sheets.
There is a font end to this macro where data is put in i.e. number of sheets, header row, column containing Key and Sheet names to split as shown in link below.
Dropbox - Capture.PNG
The data has the following layout.
Dropbox - CaptureData.PNG
The code which runs everything is below, hope someone can help me overcome this.
Thanks in advance.
Hope everyone is well, I have been given a macro file to Split documents based on a Key in column A, this works perfect for where there is only one sheet to split. However if there is more than one sheet within the file to split it only does the 1st sheet and ignores the rest. Is there a way to amend this code to run across multiple sheets.
There is a font end to this macro where data is put in i.e. number of sheets, header row, column containing Key and Sheet names to split as shown in link below.
Dropbox - Capture.PNG
The data has the following layout.
Dropbox - CaptureData.PNG
The code which runs everything is below, hope someone can help me overcome this.
Thanks in advance.
Code:
Option Explicit
Public wbSplit As Workbook, wbTarget As Workbook, wbOutput As Workbook
Public wsSplit As Worksheet, wsData As Worksheet, wsTarget As Worksheet, wsOutput As Worksheet
Dim sPath As String, sType As String, sFile As String, sKey As String, sFullPath As String
Dim iFSheet As Integer, iLSheet As Integer, iHTop As Integer, iHBot As Integer, iFormat As Integer, iRow As Integer, iCount As Integer, i As Integer
Dim lRow As Long, lCol As Long, lFRow As Long, lFCol As Long, lLRow As Long, lLCol As Long, lKeyCol As Long, lORow As Long, lLRow_global As Long
Dim rHeader As Range, rKey As Range, rKeys As Range, rLine As Range
Dim pCache As PivotCache
Sub Wrapper()
Run INIT()
Run READVALS()
Run SPLITPREP()
Run SPLITFILE()
Run DEINIT()
MsgBox "Split completed!"
End Sub
Function INIT()
'Make basic settings
Set wbSplit = ThisWorkbook: Set wsSplit = wbSplit.Sheets("SPLIT"): Set wsData = wbSplit.Sheets("DATA")
'Clean Key Column handling
wsData.Range("C:C").ClearContents: wsData.Range("C:C").ClearFormats: wsData.Range("C1").Value = "KEY_ENTRIES"
End Function
Function DEINIT()
'Turn off settings to save your memory!
Set wbSplit = Nothing: Set wbTarget = Nothing: Set wbOutput = Nothing
Set wsSplit = Nothing: Set wsData = Nothing: Set wsTarget = Nothing: Set wsOutput = Nothing
Set rHeader = Nothing: Set rKey = Nothing: Set rKeys = Nothing: Set rLine = Nothing
Set pCache = Nothing
sPath = vbNullString: sType = vbNullString: sFile = vbNullString: sKey = vbNullString
iFSheet = Empty: iLSheet = Empty: iHTop = Empty: iHBot = Empty: iFormat = Empty: iRow = Empty: iCount = Empty: i = Empty
lRow = Empty: lCol = Empty: lFRow = Empty: lFCol = Empty: lLRow = Empty: lLCol = Empty: lKeyCol = Empty: lORow = Empty
End Function
Function READVALS()
'Read the settings made on the front page
With wsSplit
'Output settings
sPath = .Range("C6").Value
sType = .Range("C7").Value
iFormat = .Range("P7").Value
'SHEET SELECTION BY SHEET NAME TO HANDLE HIDDEN SHEETS
'BLOCKED DK 260516
'Sheet settings
' If IntCheck(.Range("C9").Value) = False Then
' MsgBox "Invalid value for first sheet. Reverting to 1"
' .Range("C9").Value = 1
' End If
' iFSheet = .Range("C9").Value
' If IntCheck(.Range("E9").Value) = False Then
' MsgBox "Invalid value for last sheet. Reverting to 1"
' .Range("E9").Value = 1
' End If
' iLSheet = .Range("E9").Value
If Len(.Range("H9").Value) < 1 Then MsgBox "Invalid Sheet Name"
'Header settings
If IntCheck(.Range("C10").Value) = False Then
MsgBox "Invalid top header row setting. Reverting 1."
.Range("C10").Value = 1
End If
iHTop = .Range("C10").Value
If IntCheck(.Range("E10").Value) = False Then
MsgBox "Invalid bottom header row setting. Reverting 1."
.Range("E10").Value = 1
End If
iHBot = .Range("E10").Value
'Key column setting
On Error Resume Next
If wsData.Range(.Range("C11").Value & 1) Is Nothing Then
MsgBox "Invalid key column setting. Reverting to A."
.Range("C10").Value = "A"
End If
On Error GoTo 0
lKeyCol = ConvertCol(.Range("C11").Value)
End With
End Function
Function SPLITPREP()
'Open the workbook to be split and make some basic checks and settings
Set wbTarget = Workbooks.Open(Application.GetOpenFilename("Excel Fles, *.xls*"))
sFullPath = wbTarget.FullName
If bLocateSheet(wsSplit.Range("H9").Value) = False Then MsgBox "Invalid Sheet Name"
iCount = wbTarget.Sheets.Count
Do While iFSheet > iCount
iFSheet = InputBox("The requested first sheet number, " & CStr(iFSheet) & ", has not been found on the sheet. There are only " & CStr(iCount) & " sheets in the file. Please enter a valid sheet number and try again.", "Select first sheet to split", 1)
Loop
Do While iLSheet > iCount
iLSheet = InputBox("The requested last sheet number, " & CStr(iLSheet) & ", has not been found on the sheet. There are only " & CStr(iCount) & " sheets in the file. Please enter a valid sheet number and try again.", "Select last sheet to split", iCount)
Loop
'Get the target file name
sFile = Replace(Replace(Replace(wbTarget.Name, ".xlsx", ""), ".xlsm", ""), ".xls", "")
'Create the key entry list
Set wsTarget = wbTarget.Sheets(iFSheet)
Dim ic As Integer
Debug.Print wsTarget.Name
lLRow = wsTarget.Cells(iHBot, lKeyCol).End(xlDown).Row
Dim answer As Integer
answer = MsgBox("Detected last row in the splitting column (Is this correct Y/N?): " & lLRow, vbYesNo + vbQuestion)
If answer = vbNo Then
lLRow_global = InputBox("Enter the correct last row # in the spliting column: ")
End If
If answer = vbYes Then
lLRow_global = lLRow
End If
lLRow = lLRow_global
lRow = iHBot + 1
Do While lRow <= lLRow
With wsTarget.Cells(lRow, lKeyCol)
If WorksheetFunction.IsError(.Value) Then
.Value = "ERROR"
Else
.Value = StringCheck(.Value)
End If
End With
lRow = lRow + 1
Loop
'Pull out a list of unique values from the key column and copy them to the dataset
wsTarget.AutoFilterMode = False
Dim c As Range
Dim temp As String
For Each c In wsTarget.UsedRange.Cells
If c.PrefixCharacter <> vbNullString Then
temp = c.Text
c.Clear
c.Value = temp
End If
Next
wbTarget.Save
wsTarget.Activate
wsTarget.Range(wsTarget.Cells(iHBot + 1, lKeyCol), wsTarget.Cells(lLRow, lKeyCol)).Select
Selection.Copy
wsData.Range("C2").PasteSpecial xlPasteValues
wsData.Columns("C:C").RemoveDuplicates Columns:=1, Header:=xlYes
Dim ccc As Integer
ccc = 2
For i = 2 To 1000
If wsData.Cells(i, 3).Value = "" Then
wsData.Cells(i, 3).Delete Shift:=xlUp
i = i - 1
End If
ccc = ccc + 1
If ccc = 1000 Then
i = 1000
End If
Next
wbTarget.Close False
'set the key column
Set rKeys = wsData.Range("C2:C" & CStr(wsData.Range("C1").End(xlDown).Row))
End Function
Function SPLITFILE()
'Split the file
'For each unique key in the unique key range
For Each rKey In rKeys
sKey = rKey.Value
Set wbOutput = Workbooks.Open(sFullPath)
'Cycle through all the sheets in the given range
For i = iFSheet To iLSheet
Set wsOutput = wbOutput.Sheets(i)
'Find up/down extent of dataset
lFRow = iHBot + 1
lLRow = lLRow_global
'Set the row counter to the top of the target sheet
lRow = lFRow
'Run through each line, checking, deleting those where key does not match
Do While lRow <= lLRow
If wsOutput.Cells(lRow, lKeyCol).Value <> sKey Then
wsOutput.Rows(lRow).Delete
lLRow = lLRow - 1
Else
lRow = lRow + 1
End If
Loop
Next i
'Refresh any pivot tables
For Each pCache In wbOutput.PivotCaches
pCache.Refresh
Next pCache
'Save the output file
Application.DisplayAlerts = False
Debug.Print sPath
wbOutput.SaveAs sPath & "" & sFile & " - " & sKey & "." & sType, iFormat
wbOutput.Close False
Next rKey
End Function
Function IntCheck(iValue As Integer) As Boolean
'Function to check if a value is a valid integer. Returns true if it is, false if not.
If iValue = Empty Then
IntCheck = False
ElseIf Not (IsNumeric(iValue)) Then
IntCheck = False
ElseIf iValue < 1 Then
IntCheck = False
ElseIf (iValue / iValue) <> 1 Then
IntCheck = False
Else
IntCheck = True
End If
End Function
Function StringCheck(sInput As String) As String
'Function to remove non-printable characters from a string
StringCheck = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(sInput, "|", "_"), ">", "_"), "<", "_"), Chr(34), "_"), "?", "_"), "*", "_"), ":", "_"), "/", "_"), "", "_")
End Function
Function ConvertCol(sInput As String) As Long
'Get the key column and converted to numeric value
ConvertCol = wsData.Range(sInput & 1).Column
'ConvertCol = Asc(sInput) - 64
End Function
Function bLocateSheet(sSheetName As String) As Boolean
Dim ws As Worksheet
bLocateSheet = False
For Each ws In wbTarget.Worksheets
If UCase(ws.Name) = UCase(sSheetName) Then
iFSheet = ws.Index
iLSheet = iFSheet
bLocateSheet = True
Exit For
End If
Next
End Function
Sub UnhideAllSheets()
'Unhide all sheets in workbook.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
Last edited by a moderator:
