2
我试图电池串分割成不同的细胞在一个excel电子表格，然后复制和细胞分裂与新标题粘贴到一个新的工作表。下面是我想要分裂的图像。Excel中VBA-拆分单元格字符串成单个细胞和细胞复制新表
这里就是我想要的目的。 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让我们把它作为逗号，我将改变屏幕截图 – smurf
最简单的方法是将所有不同的分隔符替换为单一类型，然后拆分。 –