How to convert lots of columns of data all into just one column easily?

S

smerrick

Active Member
Joined
Feb 10, 2009
Messages
255
Hello,

Thanks for reading.

I have columns of data from column C right through to column WZZ. What I want to do is to put all of this data into column A only. Each column has the exact same amount of rows - data starts at row 6 and finishes at to 2,500.

Is there a qucik way to do this?


Kind Regards
 
Sort by date Sort by votes
Oops. Try again:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
    Else
        k = 0
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next j
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase a
        Erase b
    End If
    Set r = Nothing
End Sub
 
Last edited:
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
with optional csv export if there are just too many values:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    k = 0
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
        If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
            Open "c:\export.csv" For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  '<-- Change c:\export.csv to whatever you would like.
            For j = 1 To UBound(a, 2)
                For i = 1 To UBound(a)
                    If LenB(a(i, j)) Then
                        k = k + 1
                        Write [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                    End If
                Next j
            Next j
            Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
        End If
    Else
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next j
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase a
        Erase b
    End If
    Set r = Nothing
End Sub
 
Upvote 0
Thanks for your expertise on this.

I tried the code but received a message stating 'Complie Error: Invalid Next control variable reference' and it is indicating this on the first 'Next j' line of code. I cannot fix this as my code knowledge is zero



trunten said:
Oops. Try again:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
    Else
        k = 0
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next j
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase a
        Erase b
    End If
    Set r = Nothing
End Sub
Click to expand...
 
Upvote 0
sorry. I'm out atm so I've just been trying to type code straight into the browser on my phone.

Think I've caught every issue now:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    Dim allowCSVExport As Boolean


    allowCSVExport = False '<-- Change to True if you want the export to csv option
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    k = 0
    a = r.Value
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
        If allowCSVExport Then
            If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
                Open "c:\export.csv" For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]   '<-- Change c:\export.csv to whatever you would like.
                For j = 1 To UBound(a, 2)
                    For i = 1 To UBound(a)
                        If LenB(a(i, j)) Then
                            k = k + 1
                            Write [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                        End If
                    Next i
                Next j
                Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
            End If
        End If
    Else
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next i
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase b
    End If
    Erase a
    Set r = Nothing
End Sub
 
Upvote 0
Thanks again, working on your coding whilst out and about on your phone is highly impressive. Still, I have copied what you did and still no luck - is it easy to whack it into an excel file and to send over so that I can see it in action? More likely user error my end.





trunten said:
sorry. I'm out atm so I've just been trying to type code straight into the browser on my phone.

Think I've caught every issue now:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    Dim allowCSVExport As Boolean


    allowCSVExport = False '<-- Change to True if you want the export to csv option
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    k = 0
    a = r.Value
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
        If allowCSVExport Then
            If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
                Open "c:\export.csv" For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]   '<-- Change c:\export.csv to whatever you would like.
                For j = 1 To UBound(a, 2)
                    For i = 1 To UBound(a)
                        If LenB(a(i, j)) Then
                            k = k + 1
                            Write [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                        End If
                    Next i
                Next j
                Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] 
            End If
        End If
    Else
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next i
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase b
    End If
    Erase a
    Set r = Nothing
End Sub
Click to expand...
 
Upvote 0
Not sure what I did wrong but yes your code works perfectly now - works as intended and is highly impressive. Big thank you all round, very impressive skills set


smerrick said:
Thanks again, working on your coding whilst out and about on your phone is highly impressive. Still, I have copied what you did and still no luck - is it easy to whack it into an excel file and to send over so that I can see it in action? More likely user error my end.
Click to expand...
 
Upvote 0
How easy is it to modify the code so that once it looks at the first tab and brings in the data into more column, it then looks at the next tab and does the same process, and then the next tab, etc?




trunten said:
sorry. I'm out atm so I've just been trying to type code straight into the browser on my phone.

Think I've caught every issue now:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    Dim allowCSVExport As Boolean


    allowCSVExport = False '<-- Change to True if you want the export to csv option
    
    lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    Set r = Range("A6", Cells(lastRow, "WZ"))
    totalValues = Application.CountA(r)
    k = 0
    a = r.Value
    If totalValues > Rows.Count Then
        MsgBox "Can't be done. Not enough rows!!!", vbCritical
        If allowCSVExport Then
            If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
                Open "c:\export.csv" For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]   '<-- Change c:\export.csv to whatever you would like.
                For j = 1 To UBound(a, 2)
                    For i = 1 To UBound(a)
                        If LenB(a(i, j)) Then
                            k = k + 1
                            Write [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                        End If
                    Next i
                Next j
                Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] 
            End If
        End If
    Else
        ReDim b(1 To totalValues, 1 To 1)
        For j = 1 To UBound(a, 2)
            For i = 1 To UBound(a)
                If LenB(a(i, j)) Then
                    k = k + 1
                    b(k, 1) = a(i, j)
                End If
            Next i
        Next j
        Workbooks.Add.Sheets(1).Range("A1").Resize(totalValues).Value = b
        Erase b
    End If
    Erase a
    Set r = Nothing
End Sub
Click to expand...
 
Upvote 0
That would be pretty straightforward. You could use this:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    Dim allowCSVExport As Boolean
    Dim outputWb As Workbook, outputSht As Worksheet, sht As Worksheet


    allowCSVExport = False '<-- Change to True if you want the export to csv option
    
    For Each sht In ActiveWorkbook.Sheets
        lastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
        Set r = sht.Range("A6", sht.Cells(lastRow, "WZ"))
        totalValues = Application.CountA(r)
        k = 0
        a = r.Value
        If outputWb Is Nothing Then
            Set outputWb = Workbooks.Add
            Set outputSht = outputWb.Sheets(1)
        Else
            Set outputSht = outputWb.Sheets.Add(After:=outputWb.Sheets(outputWb.Sheets.Count))
        End If
        If totalValues > outputSht.Rows.Count Then
            MsgBox "Can't be done. Not enough rows!!!", vbCritical
            If allowCSVExport Then
                If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
                    Open "c:\export.csv" For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]    '<-- Change c:\export.csv to whatever you would like.
                    For j = 1 To UBound(a, 2)
                        For i = 1 To UBound(a)
                            If LenB(a(i, j)) Then
                                k = k + 1
                                Write [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                            End If
                        Next i
                    Next j
                    Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
                End If
            End If
        Else
            ReDim b(1 To totalValues, 1 To 1)
            For j = 1 To UBound(a, 2)
                For i = 1 To UBound(a)
                    If LenB(a(i, j)) Then
                        k = k + 1
                        b(k, 1) = a(i, j)
                    End If
                Next i
            Next j
            outputSht.Range("A1").Resize(totalValues).Value = b
            Erase b
        End If
        Erase a
        Set r = Nothing
    Next sht
End Sub

However, because I like to try and make my code more than just single use, personally I'd probably do something like this:

Code: 
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 <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".
'
'   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.
'
'   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 <dest> is provided then that sheet will contain a Hyperlink
'                to the exported CSV file.
'
'Example usage:
'   combineSheetCols ActiveSheet
'   success = combineSheetCols(ActiveSheet)
'   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 Worksheet, _
        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
    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
    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 <arr> 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 <arr> 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 <arr> 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
 
Upvote 0
[TABLE="width: 749"]
<tbody>[TR]
[TD]Absolute genius this code - thank you, I hope your making vast sums in some financial institution with your vb magic![/TD]
[/TR]
</tbody><colgroup><col></colgroup>[/TABLE]




trunten said:
That would be pretty straightforward. You could use this:

Code: 
Sub combineCols()
    Dim r As Range
    Dim a(), b()
    Dim lastRow As Long, totalValues As Long, i As Long, j As Long, k As Long
    Dim allowCSVExport As Boolean
    Dim outputWb As Workbook, outputSht As Worksheet, sht As Worksheet


    allowCSVExport = False '<-- Change to True if you want the export to csv option
    
    For Each sht In ActiveWorkbook.Sheets
        lastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
        Set r = sht.Range("A6", sht.Cells(lastRow, "WZ"))
        totalValues = Application.CountA(r)
        k = 0
        a = r.Value
        If outputWb Is Nothing Then
            Set outputWb = Workbooks.Add
            Set outputSht = outputWb.Sheets(1)
        Else
            Set outputSht = outputWb.Sheets.Add(After:=outputWb.Sheets(outputWb.Sheets.Count))
        End If
        If totalValues > outputSht.Rows.Count Then
            MsgBox "Can't be done. Not enough rows!!!", vbCritical
            If allowCSVExport Then
                If MsgBox("Would you like to export to a csv?", vbYesNo + vbInformation) = vbYes Then
                    Open "c:\export.csv" For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]    '<-- Change c:\export.csv to whatever you would like.
                    For j = 1 To UBound(a, 2)
                        For i = 1 To UBound(a)
                            If LenB(a(i, j)) Then
                                k = k + 1
                                Write [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , IIf(k > 1, vbCrLf, "") & a(i, j)
                            End If
                        Next i
                    Next j
                    Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] 
                End If
            End If
        Else
            ReDim b(1 To totalValues, 1 To 1)
            For j = 1 To UBound(a, 2)
                For i = 1 To UBound(a)
                    If LenB(a(i, j)) Then
                        k = k + 1
                        b(k, 1) = a(i, j)
                    End If
                Next i
            Next j
            outputSht.Range("A1").Resize(totalValues).Value = b
            Erase b
        End If
        Erase a
        Set r = Nothing
    Next sht
End Sub

However, because I like to try and make my code more than just single use, personally I'd probably do something like this:

Code: 
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  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".
'
'   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.
'
'   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 <dest> is provided then that sheet will contain a Hyperlink
'                to the exported CSV file.
'
'Example usage:
'   combineSheetCols ActiveSheet
'   success = combineSheetCols(ActiveSheet)
'   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 Worksheet, _
        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
    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
    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 <arr> 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 <arr> 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 <arr> 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
Click to expand...

</arr></arr></arr></dest>
 
Upvote 0
No problem at all.

Hopefully you will see that:
typeOfArray can all be used in any project with no dependencies.
flattenArray and outputArrayAsCSV can be used so long as they are in a project which includes typeOfArray
combineSheetCols will also need you to include the above 3 functions as it makes use of each of these.

combineAllSheets as actually pretty simple all told which simply leverages the helper functions to perform it's task and should probably be considered as standalone sub-routine specific to this project only (it could, however, be adapted quite easily).
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
292
Alex Blakenburg
A
M
  • Solved
VBA Use formula within all cells within a range (across numerous columns and rows), referencing row 5 in given column
Replies
4
Views
372
Moley84
M
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
427
mumps
mumps
N
  • Question Question
save table data to query
Replies
1
Views
196
GraH
GraH
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
525
Akuini
Akuini

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top