我正在尝试将单元格字符串拆分为一个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
提前感谢您的帮助！
答案 0 :(得分：2)
编辑：更新和测试 - 适用于您的“设置”数据
Sub Sample()
Dim MYAr, setup
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long
Dim arrHeaders
Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
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 + 1, 1).Value = "Microphone"
setup = .Range("B" & i).Value
If Len(setup) > 0 Then
MYAr = SetupToArray(setup)
'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
'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....
rw = rw + 6
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
答案 1 :(得分：1)
更容易将范围复制到Windows剪贴板并使用TSV文本格式（未经测试）：
Sheet1.Cells.Copy ' copy the range
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' this is late bound MSForms.DataObject
Dim s As String
.GetFromClipboard ' get the formats from the Windows Clipboard
s = .GetText ' get the "Text" format
Application.CutCopyMode = False
' magic
s = Replace(s, "MC ", "MC") ' "MC 1" to "MC1"
s = Replace(s, " x ", "|") ' "1 x 18" to "1|18"
s = Replace(s, " , ", "|") ' "18 , MC" to "18|MC"
s = Replace(s, ": ", "|") ' "MC1: 1" to "MC1|1"
s = Replace(s, " ", "|") ' "2|PHILIP DYNAMI SBMCMD" to "2|PHILIP|DYNAMI|SBMCMD"
' "more magic"
s = Replace(s, "Setup" & vbTab, "/Setup||Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People/||")
s = Replace(s, "Microphone" & vbTab, "/Microphone||Number|manufacturer|Model|Model Num/||")
s = Replace(s, "|", vbTab) ' cells are separated by tab
s = Replace(s, "/", vbNewLine) ' rows are separated by new line
.SetText s
.PutInClipboard
End With
Sheet2.PasteSpecial "Text" ' or Sheet2.Range("A1").PasteSpecial