Page 3 of 4 FirstFirst 1234 LastLast
Results 21 to 30 of 32

Thread: How to convert lots of columns of data all into just one column easily?
Thanks Thanks: 0 Likes Likes: 0

  1. #21
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    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 by trunten; Jul 26th, 2019 at 08:38 AM.

  2. #22
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    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 #1  '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                        End If
                    Next j
                Next j
                Close #1 
            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

  3. #23
    Board Regular
    Join Date
    Feb 2009
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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



    Quote Originally Posted by trunten View Post
    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

  4. #24
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    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 #1   '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                            End If
                        Next i
                    Next j
                    Close #1 
                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

  5. #25
    Board Regular
    Join Date
    Feb 2009
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.





    Quote Originally Posted by trunten View Post
    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 #1   '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                            End If
                        Next i
                    Next j
                    Close #1 
                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

  6. #26
    Board Regular
    Join Date
    Feb 2009
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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


    Quote Originally Posted by smerrick View Post
    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.

  7. #27
    Board Regular
    Join Date
    Feb 2009
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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?




    Quote Originally Posted by trunten View Post
    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 #1   '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                            End If
                        Next i
                    Next j
                    Close #1 
                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

  8. #28
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    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 #1    '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                                End If
                            Next i
                        Next j
                        Close #1 
                    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  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  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 #fnum 
                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 #fnum , line
                Next i
                Close #fnum 
                success = True
            End If
        End If
    clean_exit:
        On Error GoTo 0
        outputArrayAsCSV = IIf(success, fpath, vbNullString)
    End Function

  9. #29
    Board Regular
    Join Date
    Feb 2009
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Absolute genius this code - thank you, I hope your making vast sums in some financial institution with your vb magic!




    Quote Originally Posted by trunten View Post
    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 #1    '<-- 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 #1 , IIf(k > 1, vbCrLf, "") & a(i, j)
                                End If
                            Next i
                        Next j
                        Close #1 
                    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  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  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 #fnum 
                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 #fnum , line
                Next i
                Close #fnum 
                success = True
            End If
        End If
    clean_exit:
        On Error GoTo 0
        outputArrayAsCSV = IIf(success, fpath, vbNullString)
    End Function

  10. #30
    Board Regular
    Join Date
    Jul 2011
    Posts
    475
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

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

    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 by trunten; Jul 30th, 2019 at 01:56 PM.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •