Option Explicit
Sub combineAllSheets()
Dim sht As Worksheet, outputSht As Worksheet
Dim outputWb As Workbook, sourceWb As Workbook
Dim i As Long
Dim appendSheets As Boolean, success As Boolean
appendSheets = False '<-- Set to True if you want to add the sheets to the source workbook rather than create a new one.
Application.ScreenUpdating = False
On Error GoTo clean_exit
'If you want to always reference this workbook as opposed to the currently active
'workbook then change the line below to: Set sourceWb = ThisWorkbook
Set sourceWb = ActiveWorkbook
If appendSheets Then
Set outputWb = sourceWb
i = outputWb.Sheets.Count
Else
Set outputWb = Workbooks.Add
i = 0
End If
For Each sht In sourceWb.Sheets
i = i + 1
While outputWb.Sheets.Count < i
outputWb.Sheets.Add After:=outputWb.Sheets(outputWb.Sheets.Count)
Wend
Set outputSht = outputWb.Sheets(i)
success = combineSheetCols( _
source:=sht, _
dataStart:="A6", _
colLimit:="WZ", _
dest:=outputSht, _
skipBlanks:=True, _
csvFallback:=True)
If Not success Then
Application.DisplayAlerts = False
If outputWb.Sheets.Count > 1 Then outputSht.Delete
Application.DisplayAlerts = True
i = i - 1
End If
Next sht
outputWb.Activate
clean_exit:
Set sht = Nothing
Set sourceWb = Nothing
Set outputSht = Nothing
Set outputWb = Nothing
Application.ScreenUpdating = True
If Err.Number Then Err.Raise (Err)
End Sub
'Combines the values on the supplied sheet/range 'source' into a single column.
'Returns True if the operation was successful; False otherwise (logs failure to Immediate window).
'Optional Parameters:
' dataStart: A string value representing the first cell where data is found (eg. "A2").
' If omitted the function defaults to "A1" (Ignored if 'source' is a range).
'
' colLimit: A string value representing the last column in which data is found (eg. "Z").
' If omitted the function defaults to the last used column (Ignored if 'source' is a range).
'
' dest: A Worksheet object to be used as the output for the combined values.
' If omitted then the function will create a new blank workbook to output values.
'
' skipBlanks: If set to True then only none blank values are output
'
' csvFallback: If set to True then if there are too many values to be combined into a single
' column then the function will prompt for a save path and output to a CSV file.
' If a destination sheet is provided then that sheet will contain a Hyperlink
' to the exported CSV file.
'
'Example usage:
' combineSheetCols ActiveSheet
' success = combineSheetCols(ActiveSheet)
' success = combineSheetCols(ActiveSheet.Range("A6:W50"))
' success = combineSheetCols(mySheet, "A6", "WZ")
' success = combineSheetCols(mySheet, dest:=myNewSheet, skipBlanks:=True)
' success = combineSheetCols(mySheet, skipBlanks:=True, csvFallback:=True)
' success = combineSheetCols(ActiveSheet, dataStart:="A2", csvFallback:=True)
Function combineSheetCols(ByRef source As Variant, _
Optional ByVal dataStart As String = "A1", _
Optional ByVal colLimit As String = "", _
Optional ByRef dest As Worksheet, _
Optional ByVal skipBlanks As Boolean = False, _
Optional ByVal csvFallback As Boolean = False) As Boolean
Dim r As Range, lastCell As Range
Dim a(), b()
Dim totalValues As Long, i As Long, j As Long, k As Long
Dim success As Boolean
success = False
If TypeOf source Is Range Then
Set r = source
Set source = r.Worksheet
ElseIf TypeOf source Is Worksheet Then
Set lastCell = source.Cells.SpecialCells(xlCellTypeLastCell)
On Error Resume Next
If LenB(colLimit) Then
Set r = source.Range(dataStart, source.Cells(lastCell.Row, colLimit))
Else
Set r = source.Range(dataStart, lastCell)
End If
On Error GoTo 0
Else
MsgBox "Invalid source parameter!", vbCritical
End
End If
If Not r Is Nothing Then
If skipBlanks Then
totalValues = Application.CountA(r)
Else
totalValues = r.Count
End If
k = 0
If r.Count > 1 Then
a = r.Value
Else
a = Array(r.Value)
End If
If totalValues > Rows.Count Then
If MsgBox("Columns can not be combined for sheet: " & source.Name & vbLf & _
"Too many values (" & totalValues & ")" & _
IIf(csvFallback, vbLf & vbLf & "Would you like to export the values to a CSV?", ""), _
vbCritical + IIf(csvFallback, vbYesNo, 0)) = vbYes Then
Dim fn As String
fn = outputArrayAsCSV(flattenArray(a, skipBlanks), source.Name & ".csv")
If LenB(fn) Then
success = True
If Not dest Is Nothing Then dest.Range("A1").Formula = "=HYPERLINK(""" & fn & """, ""Output as CSV: " & fn & """)"
End If
Else
Debug.Print "Too many values in sheet: " & source.Name, "Skipping"
End If
ElseIf totalValues > 0 Then
b = flattenArray(a, skipBlanks)
If dest Is Nothing Then Set dest = Workbooks.Add.Sheets(1)
dest.Cells.Clear
dest.Range("A1").Resize(totalValues).Value = Application.Transpose(b)
Erase b
success = True
Else
Debug.Print "No values found in sheet: " & source.Name, "Skipping"
End If
Erase a
Set r = Nothing
Else
Debug.Print "---------------------------------"
Debug.Print "Range assignment failed. Skipping"
Debug.Print "---------------------------------"
Debug.Print "Sheet: " & source.Name
Debug.Print "Data Start: " & dataStart
Debug.Print "Last Column: " & colLimit
Debug.Print "---------------------------------"
End If
Set lastCell = Nothing
combineSheetCols = success
End Function
'Returns the type of the supplied array as a number
' 0 = not a valid array
' 1 = a one-dimensional array
' 2 = a two-dimensional array
'
'Example usage:
' thisType = typeOfArray(myArray)
Function typeOfArray(ByRef arr As Variant) As Long
Dim isArray As Boolean, is2dArray As Boolean
On Error Resume Next
isArray = UBound(arr) > -1
is2dArray = UBound(arr, 2) > -1
On Error GoTo 0
If is2dArray Then
typeOfArray = 2
ElseIf isArray Then
typeOfArray = 1
Else
typeOfArray = 0
End If
End Function
'Returns the supplied array as a new one-dimensional array.
'If a one-dimensional array is supplied as input then the function returns a copy.
'Optional Parameters:
' skipBlanks: If set to true then the returned array will be dimensioned to only include none blank values
'
'#Notes: If a one-dimensional array is supplied and combined with skipBlanks=true then a new array will be returned stripped of blank values.
'
'Example usage:
' myNewArray = flattenArray(my2dArray)
' myNewArray = flattenArray(my2dArray, True)
' myNewArray = flattenArray(my1dArray, True)
Function flattenArray(ByRef arr As Variant, Optional skipBlanks As Boolean = False) As Variant()
Dim arrayType As Long
Dim flatArr() As Variant, currentValue As Variant
Dim i As Long, j As Long, colStart As Long, colEnd As Long
arrayType = typeOfArray(arr)
If arrayType Then
ReDim flatArr(0)
colStart = 1: colEnd = 1
If arrayType = 2 Then
colStart = LBound(arr, 2)
colEnd = UBound(arr, 2)
End If
For j = colStart To colEnd
For i = LBound(arr) To UBound(arr)
If arrayType = 2 Then
currentValue = arr(i, j)
Else
currentValue = arr(i)
End If
If Not skipBlanks Or LenB(currentValue) Then
If UBound(flatArr) = 0 Then
ReDim flatArr(1 To 1)
Else
ReDim Preserve flatArr(1 To UBound(flatArr) + 1)
End If
flatArr(UBound(flatArr)) = currentValue
End If
Next i
Next j
Else
ReDim flatArr(1 To 1)
End If
flattenArray = flatArr
End Function
'Outputs the supplied array as a CSV file.
'Returns the output path if successful and a blank string otherwise.
'Optional parameters:
' fname: A string value which, if supplied, will be used as the default CSV filename
' fpath: A string value which, if supplied (and valid) will be used as the default CSV save path
'
'#Notes: If both fname and fpath are provided (and are valid) then the function will not prompt for a save path
'
'Example usage:
' outputArrayAsCSV myArray
' path = outputArrayAsCSV(myArray)
' path = outputArrayAsCSV(myArray, "My new csv file.csv")
' path = outputArrayAsCSV(myArray, "My new csv file.csv", "C:\")
Function outputArrayAsCSV(ByRef arr As Variant, Optional fname As String = "", Optional ByVal fpath As String = "") As String
Dim arrayType As Long, i As Long, j As Long, fnum As Long
Dim line As String
Dim success As Boolean
success = False
arrayType = typeOfArray(arr)
If arrayType Then
If fname = "" Then fname = "Array_output.csv"
If CreateObject("Scripting.FileSystemObject").folderexists(fpath) Then
fpath = fpath & IIf(Right(fpath, 1) = "\", "", "\") & fname
Else
fpath = Application.GetSaveAsFilename(fname, "CSV (*.csv), *.csv")
End If
If fpath <> "False" Then
fnum = FreeFile
On Error GoTo clean_exit
Open fpath For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum"]#fnum[/URL]
For i = LBound(arr) To UBound(arr)
line = ""
If arrayType = 1 Then
line = arr(i)
ElseIf arrayType = 2 Then
For j = LBound(arr, 2) To UBound(arr, 2)
line = line & IIf(line = "", "", ",") & arr(i, j)
Next j
End If
Print [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum"]#fnum[/URL] , line
Next i
Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum"]#fnum[/URL]
success = True
End If
End If
clean_exit:
On Error GoTo 0
outputArrayAsCSV = IIf(success, fpath, vbNullString)
End Function
