none
vba RRS feed

  • Question

  • I am running the code below, which is running down 1 column of data that has multiple values in one cell separated by a comma.  We want to separate these values into multiple columns.  The code runs, but we have to click through a pop up box to replace destination cells.  When clicking ok, the macro does not separate the data.

     Sub Test()
          ' Select cell x2, *first line of data*.
          Range("x2").Select
          ' Set Do loop to stop when an empty cell is reached.
          Do Until IsEmpty(ActiveCell)
                      Selection.TextToColumns Destination:=Range("y2"), DataType:=xlFixedWidth _
            , FieldInfo:=Array(Array(0, 1), Array(7, 1)), TrailingMinusNumbers:=True
             ' Step down 1 row from present location.
             ActiveCell.Offset(1, 0).Select
          Loop
       End Sub

    Thursday, May 19, 2016 3:22 PM

Answers

  • Hi lsorgelis,

    Try to use the code below it will split the data from 1 cell to multiple cells delimited by ",".

    Option Explicit
    Public Const sourceColumnName As String = "A"
    Public Const delimiter As String = ","
    Public Sub Splitter()
    
        ' splits one column into multiple columns
     
        Dim sourceSheetName As String
        Dim sourceSheet As Worksheet
        Dim LastRow As Long
        Dim uboundMax As Integer
        Dim result
    
        On Error GoTo SplitterErr
    
        sourceSheetName = "Sheet1"
        'VBA.InputBox ("Enter name of the worksheet:")
    
        If sourceSheetName = "" Then _
            Exit Sub
    
        Set sourceSheet = Worksheets(sourceSheetName)
    
        With sourceSheet
            LastRow = .Range(sourceColumnName & .Rows.Count).End(xlUp).Row
            result = SplittedValues(data:=.Range(.Cells(1, sourceColumnName), _
                                                 .Cells(LastRow, sourceColumnName)), _
                                    partsMaxLenght:=uboundMax)
    
            If Not IsEmpty(result) Then
                .Range(.Cells(1, sourceColumnName), _
                       .Cells(LastRow, uboundMax)).value = result
            End If
        End With
    
    SplitterErr:
        If Err.Number <> 0 Then _
            MsgBox Err.Description, vbCritical
    End Sub
    
    Private Function SplittedValues( _
        data As Range, _
        ByRef partsMaxLenght As Integer) As Variant
    
        Dim R As Integer
        Dim parts As Variant
        Dim values As Variant
        Dim value As Variant
        Dim splitted As Variant
    
        If Not IsArray(data) Then
            ' data consists of one cell only
            ReDim values(1 To 1, 1 To 1)
            values(1, 1) = data.value
        Else
            values = data.value
        End If
    
        ReDim splitted(LBound(values) To UBound(values))
    
        For R = LBound(values) To UBound(values)
    
            value = values(R, 1)
            If IsEmpty(value) Then
                GoTo continue
            End If
    
            ' Split always returns zero based array so parts is zero based array
            parts = VBA.Split(value, delimiter)
            splitted(R) = parts
    
            If UBound(parts) + 1 > partsMaxLenght Then
                partsMaxLenght = UBound(parts) + 1
            End If
    
    continue:
        Next R
    
        If partsMaxLenght = 0 Then
            Exit Function
        End If
    
        Dim matrix As Variant
        Dim c As Integer
        ReDim matrix(LBound(splitted) To UBound(splitted), _
                     LBound(splitted) To partsMaxLenght)
    
        For R = LBound(splitted) To UBound(splitted)
            parts = splitted(R)
            For c = 0 To UBound(parts)
                matrix(R, c + 1) = parts(c)
            Next c
        Next R
    
        SplittedValues = matrix
    End Function
     

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, May 20, 2016 10:38 AM
    Moderator

All replies

  • Are talking about VBA in an Excel macro?

    I'm afraid you are in the wrong forum - the Excel for Developers forum sounds like a better fit for what you are asking.

    Thursday, May 19, 2016 4:15 PM
  • Hi lsorgelis,

    Based on your code, your case more related to Excel, I will help move your case to Excel for Developers forum for better support.

    Best regards,

    Kristin


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, May 20, 2016 8:12 AM
  • Hi lsorgelis,

    Try to use the code below it will split the data from 1 cell to multiple cells delimited by ",".

    Option Explicit
    Public Const sourceColumnName As String = "A"
    Public Const delimiter As String = ","
    Public Sub Splitter()
    
        ' splits one column into multiple columns
     
        Dim sourceSheetName As String
        Dim sourceSheet As Worksheet
        Dim LastRow As Long
        Dim uboundMax As Integer
        Dim result
    
        On Error GoTo SplitterErr
    
        sourceSheetName = "Sheet1"
        'VBA.InputBox ("Enter name of the worksheet:")
    
        If sourceSheetName = "" Then _
            Exit Sub
    
        Set sourceSheet = Worksheets(sourceSheetName)
    
        With sourceSheet
            LastRow = .Range(sourceColumnName & .Rows.Count).End(xlUp).Row
            result = SplittedValues(data:=.Range(.Cells(1, sourceColumnName), _
                                                 .Cells(LastRow, sourceColumnName)), _
                                    partsMaxLenght:=uboundMax)
    
            If Not IsEmpty(result) Then
                .Range(.Cells(1, sourceColumnName), _
                       .Cells(LastRow, uboundMax)).value = result
            End If
        End With
    
    SplitterErr:
        If Err.Number <> 0 Then _
            MsgBox Err.Description, vbCritical
    End Sub
    
    Private Function SplittedValues( _
        data As Range, _
        ByRef partsMaxLenght As Integer) As Variant
    
        Dim R As Integer
        Dim parts As Variant
        Dim values As Variant
        Dim value As Variant
        Dim splitted As Variant
    
        If Not IsArray(data) Then
            ' data consists of one cell only
            ReDim values(1 To 1, 1 To 1)
            values(1, 1) = data.value
        Else
            values = data.value
        End If
    
        ReDim splitted(LBound(values) To UBound(values))
    
        For R = LBound(values) To UBound(values)
    
            value = values(R, 1)
            If IsEmpty(value) Then
                GoTo continue
            End If
    
            ' Split always returns zero based array so parts is zero based array
            parts = VBA.Split(value, delimiter)
            splitted(R) = parts
    
            If UBound(parts) + 1 > partsMaxLenght Then
                partsMaxLenght = UBound(parts) + 1
            End If
    
    continue:
        Next R
    
        If partsMaxLenght = 0 Then
            Exit Function
        End If
    
        Dim matrix As Variant
        Dim c As Integer
        ReDim matrix(LBound(splitted) To UBound(splitted), _
                     LBound(splitted) To partsMaxLenght)
    
        For R = LBound(splitted) To UBound(splitted)
            parts = splitted(R)
            For c = 0 To UBound(parts)
                matrix(R, c + 1) = parts(c)
            Next c
        Next R
    
        SplittedValues = matrix
    End Function
     

    Regards

    Deepak


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Friday, May 20, 2016 10:38 AM
    Moderator