将一列拆分为多列

Question

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

假设我有一个工作表，例如，将其称为“ example”，并且在工作表中多个行下都有以下字符串，但所有行都在“ A”列中。

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）我应该能够指定工作表名称，例如：

worksheets（“ example”）。range（A，A）'

（2）列数和行数不是固定的，因此在运行vba脚本之前，我不知道有多少个逗号分隔值和多少行。

Answer 1

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

（请注意，直接修改了源数据，因此最终将其分为几列，并且原始的未分割状态丢失了。但是可以修改代码，以使原始数据不会被覆盖。）

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）点击模块，在里面添加代码如下。

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例程的“文本到列”向导，就可以按照上面的要求选择工作表和要处理的范围。

输入框用于获取工作表和要处理的范围，并且默认为活动工作表和选择。 当然，可以通过多种方式对此进行修改。

然后调用了内置的“文本到列”功能，尽管您没有指定，ti似乎您的第一列代表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

---