Page 4 of 4 FirstFirst ... 234
Results 31 to 32 of 32

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

  1. #31
    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?

    Hello,

    If I wanted to amend the range of my data from say BI7:BT262 how would I go about this? Would I simply amend the following piece of code:

    source:=sht, _
    dataStart:="A6", _
    colLimit:="WZ", _

    To:

    source:=sht, _
    dataStart:="BI7", _
    colLimit:="BT", _

    But by doing this the macro gives me all data below BT262 which I do not want it to do. Trying an edit such as dataEnd:="BT262T does not seem to work either.

    What am I doing wrong?

    Thanks for any help with this.




    Quote Originally Posted by trunten View Post
    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 smerrick; Aug 6th, 2019 at 07:17 AM.

  2. #32
    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?

    Hi there. Sorry it's been a while. When I'm testing that it works as expected, from BI7 to the last cell in column BT.
    However, I've change the code slightly for the combine function so you can set the source to either a worksheet or a range.
    If it is set to a worksheet then you will need to supply a value for dataStart but if source is set to a range then it ignores any values stored in dataStart and colLimit and just merges values from that range.

    so now you could to either:
    combineSheetCols(source:=sh, dataStart:="A6", colLimit:="WZ")
    OR
    combineSheetCols(source:=sht.Range("A6:WZ200"))

    (as examples)

    Here's the updated code:

    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/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 #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
    Last edited by trunten; Aug 17th, 2019 at 11:42 AM.

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
  •