将一列拆分为多列

Question

我想知道是否有人可以建议如何将带逗号分隔值的字符串拆分为多个列。我一直试图解决这个问题，但一直很难找到一个好的解决方案。 （也在线检查，似乎有几个接近，但不一定适合我真正需要的）

我们说我有一张工作表，称之为＆＃34;例如＆＃34;，例如， 并在工作表中具有多个以下字符串 列中的所有行＆＃34; A＆＃34;。

20120112,aaa,bbb,ccc,3432 
20120113,aaa,bbb,ccc
20120113,ddd,bb,ccc,ddd,eee,fff,ggg,hhhh 
20120132,aaa,bbb,ccc
20120112,aaa,bbb,ccc 
20120112,xxx,bbb,ggg,ggg,333
20120112,aaa,bbb,ccc 
20120112,abbd,bbb,ccc

如何创建将上述内容拆分为多列的宏。

只需几点

（1）我应该能够指定工作表名称 例如：

工作表（＆＃34;示例＆＃34;）。范​​围（A，A）＆＃39;

（2）列和行的数量不固定，所以我不这样做 知道有多少逗号分隔值和那里有多少行 将在我运行vba脚本之前。

Answer 1

• 您可以使用InputBox()函数并获取包含要分割的数据的工作表名称。
• 然后将数据复制到变量数组中，拆分它们并创建新的分割值数组。
• 最后将拆分值数组分配回excel范围。 HTH

（请注意，源数据会被直接修改，因此最终将其分成列，原始未拆分状态将丢失。但可以修改代码，以便原始数据不会被覆盖。）

Option Explicit

Private Const sourceColumnName As String = "A"
Private 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 = 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

Answer 2

如果您以后不再需要处理此任务，请参考以下手册：

1. 使用文本编辑器（Notepad ++）将“，”替换为“tab”。
2. 复制内容并粘贴到空的Excel表格中。

或者您可以尝试Excel从文件中导入数据（“，”作为分隔符）。

如果您需要自动脚本，请尝试以下操作： 1）按Ctrl + F11打开VBA编辑器，插入模块。 2）单击Module，在下面添加代码。

Option Explicit

Public Function LastRowWithData(ByRef sht As Excel.Worksheet, Optional colName As String = "A") As Long
    LastRowWithData = sht.Range(colName & sht.Rows.Count).End(xlUp).Row
End Function

Sub SplitToColumns(ByRef sColNames As String, ByRef strSeparator As String, ByRef rngDest As Excel.Range)
    Dim arrColNames As Variant, i As Long

    arrColNames = Split(sColNames, strSeparator)
    For i = LBound(arrColNames) To UBound(arrColNames)
        rngDest.Offset(0, i).Value = arrColNames(i)
    Next i
End Sub

Sub PerformTheSplit()
    Dim totalRows As Long, i As Long, sColNames As String

    totalRows = LastRowWithData(Sheet1, "A")
    For i = 1 To totalRows
        sColNames = Sheet1.Range("A" & i).Value
        Call SplitToColumns(sColNames, ",", Sheet2.Range("A" & i))
    Next i
End Sub

3）假设您在Sheet1中有列名：

按“Alt + F8”运行宏“PerformTheSplit”，您将在Sheet2中看到结果：

Answer 3

我会使用文本到列向导，使用VBA例程，您可以根据上面的请求选择要处理的工作表和范围。

“输入”框用于获取要处理的工作表和范围，默认为“活动工作表和选择”。这肯定可以通过各种方式进行修改。

然后调用内置的text to columns功能，虽然你没有这样指定，但是看起来你的第一列代表YMD格式的日期，所以我添加了一个选项 - 它应该是显而易见的如果需要，删除或更改它。

让我知道它对你有用：

---

Option Explicit
Sub TTC_SelectWS_SelectR()
    Dim WS As Worksheet, R As Range
    Dim sMB As String
    Dim v

On Error Resume Next
Set WS = Worksheets(Application.InputBox(Prompt:="Enter Worksheet Name: ", _
        Title:="Select Worksheet", _
        Default:=ActiveSheet.Name, _
        Type:=2))
    If Err.Number <> 0 Then
        sMB = MsgBox("Invalid Worksheet Name", vbRetryCancel)
        If sMB = vbRetry Then TTC_SelectWS_SelectR
        Exit Sub
    End If
On Error GoTo 0

    Set R = (Application.InputBox(Prompt:="Select Range to Process: ", _
                Title:="Select Range", _
                Default:=Selection.Address, _
                Type:=8))

    Set R = WS.Range(R.Address)

R.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, _
        consecutivedelimiter:=False, Tab:=False, semicolon:=False, comma:=True, Space:=False, _
        other:=False, fieldinfo:=Array(Array(1, xlYMDFormat))

End Sub

---