vba 将一列拆分为多列

Split one column into multiple columns

提问by user2511875

I was wondering if anybody can kindly advise how to split a string with comma-separated values into multiple columns. I have been trying to figure this out but have been having a hard time finding a good solution. (also checked online, seems several that comes close but not necessarily fit what I exactly need)

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

Let's say I have a worksheet, call it "example", for instance, and in the worksheet has the following strings under multiple rows but all in column "A".

假设我有一个工作表，例如，将其称为“示例”，并且在工作表中的多行下有以下字符串，但都在“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

How can I create a macro that will split the above into multiple columns.

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

Just several points

就几点

(1) I should be able to specify the worksheet name ex: something like

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

worksheets("example").range(A,A) '

工作表（“示例”）。范围（A，A）'

(2) The number of columns and rows are not fixed, and so I do not know how many comma-separated values and how many rows there would be before I run the vba script.

(2) 列数和行数不固定，所以在运行vba脚本之前不知道有多少逗号分隔值和多少行。

回答by dee

• You could use InputBox()function and get the name of the sheet with data which shlould be splitted.
• Then copy the data into variant array, split them and create new array of splitted values.
• Finally assign the array of splitted values back to excel range. HTH

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

(Notice that the source data are modified directly so finally it is separated into columns and original un-splitted state is lost. But it is possible to modify the code so the original data won't be overwritten.)

（注意，源数据是直接修改的，所以最后分列了，原来未拆分的状态丢失了。但是可以修改代码，这样原来的数据就不会被覆盖了。）

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

回答by Ron Rosenfeld

I would just use the Text-to-Columns wizard, with VBA routines to allow you to select the sheet and range to process, as you request above.

我将只使用文本到列向导，以及 VBA 例程，允许您按照上面的要求选择要处理的工作表和范围。

The Input boxes are used to obtain the sheet and range to process, and will default to the Active Sheet and Selection. This could certainly be modified in a variety of ways.

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

The built-in text to columns feature is then called, and, although you did not so specify, ti seems your first column represents a date in YMD format, so I added that as an option -- it should be obvious how to remove or change it if required.

然后调用内置文本到列功能，尽管您没有如此指定，但 ti 似乎您的第一列表示 YMD 格式的日期，因此我将其添加为一个选项 - 如何删除或如果需要，请更改它。

Let me know how it works for you:

让我知道它是如何为您工作的：

---

---

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

---

---

回答by bobyuan

If you don't need to work on this task later again, here is a manual way as workaround:

如果您以后不需要再次处理此任务，这里有一种手动方式作为解决方法：

1. Use a text editor (Notepad++) to replace "," to "tab".
2. Copy the content and paste into an empty Excel sheet.

1. 使用文本编辑器 (Notepad++) 将“,”替换为“tab”。
2. 复制内容并粘贴到空的 Excel 工作表中。

Or you can try Excel import the data from file ("," as separator).

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

In case you need an automatic script, try this: 1) Press Ctrl+F11 to open VBA editor, insert a Module. 2) click the Module, add code inside as below.

如果你需要一个自动脚本，试试这个： 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) Suppose you have the column name in Sheet1:

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

Press "Alt+F8" to run macro "PerformTheSplit", you will see result in Sheet2:

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