【发布时间】：2017-05-24 06:56:49
【问题描述】：
我正在尝试将单元格字符串拆分为一个 Excel 电子表格中的多个单元格，然后将带有新标题的拆分单元格复制并粘贴到新工作表中。下面是我要拆分的图像。
这就是我想要实现的目标。 Wanted Outcome.
不幸的是，我是 stackoverflow 的新手，所以我的图片不会显示。如果用户不想点击链接，我会尝试通过其他方式解释：
我有各种单元格，其中包含我试图拆分的长字符串。 下面是我想拆分的两行示例。
Setup | MC 1: 1 x 18 , MC 2: 2 x 23 , MC 3: 2 x 32|
------------|----------------------------------------------
Microphone | 2 x PHILIP DYNAMI SBMCMD |
（其中 | 表示分栏符）
我想将上面的标题拆分为如下所示。
Setup | |Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People|
----------------------------------------------------------------------------------
| | MC1 | 1 | 18 | MC2 | 2 | 23 | MC3 | 2 | 32 |
--------------------------------------------------------------------------------------
| | | | | | | | |
---------------------------------------------------------------------------------------
Microphone | |Number |Manufc| Model|MdlNum |
---------------------------------------------------------------------------
| | 2 |PHILIP|DYNAMI|SBMCMD |
以下代码适用于设置行。但是，它不适用于麦克风行。它设法拆分了正确的分隔符，但它没有针对包含麦克风数据的正确行。
Sub Sample()
Dim MYAr, setup
Dim MicAr, Mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long, Rrow As Long
Dim arrHeaders
Dim arrayHeadersMic
Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
'Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
Set wsOutput = ThisWorkbook.Sheets("Sheet2")
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manufacturer", "Model", "Model Number")
With ws
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
If .Cells(i, 1).Value = "Setup" Then
wsOutput.Cells(rw, 1).Value = "Setup"
wsOutput.Cells(rw + 3, 1).Value = "Microphone"
setup = .Range("B" & i).Value
If Len(setup) > 0 Then 'Len Returns an integer containing either the number of characters in a string or the nominal number of bytes required to store a variable.
MYAr = SetupToArray(setup)
'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
wsOutput.Cells(rw + 3, 3).Resize(1, 4).Value = arrHeadersMic
'fill headers across
wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(MYAr) + 1)
'populate the array
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(MYAr) + 1).Value = MYAr
'figure out the microphone values here....
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row
If .Cells(5, 1).Value = "Microphone" Then
setup = 0
Mic = .Range("B" & i).Value
'If Len(Mic) > 0 Then
MicAr = MicToArray(Mic)
'fill headers across
wsOutput.Cells(rw + 3, 3).Resize(1, 4).AutoFill _
Destination:=wsOutput.Cells(rw + 3, 3).Resize(1, UBound(MicAr) + 1) 'UBound Returns the highest available subscript for the indicated dimension of an array.
'populate the array
wsOutput.Cells(rw + 4, 3).Resize(1, UBound(MicAr) + 1).Value = MicAr
'End If
End If
rw = rw + 7
End If
End If
Next i
End With
End Sub
Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
MYAr = Split(v, ",")
'trim spaces...
For i = LBound(MYAr) To UBound(MYAr)
MYAr(i) = Trim(MYAr(i))
Next i
SetupToArray = MYAr
End Function
Function MicToArray(w)
Dim MicAr, i
w = Replace(w, " x ", " ")
'w = Replace(w, " ", ",")
MicAr = Split(w, " ")
'trimspace
For i = LBound(MicAr) To UBound(MicAr)
MicAr(i) = Trim(MicAr(i))
Next i
MicToArray = MicAr
End Function
提前感谢您的帮助！
【问题讨论】：
-
屏幕截图显示以竖线分隔，但您的示例文本以逗号分隔：哪个是实际分隔符？
-
道歉@TimWilliams 把它当作逗号，我会改截图
-
第一个最简单的方法是将所有各种分隔符替换为单一类型，然后拆分。