Excel VBA-拆分单元格串入单个单元格并将单元格复制到新表单中
我正尝试将单元格string拆分为一个Excel电子表格中的各个单元格，然后将具有新标题的拆分单元格复制并粘贴到新工作表中。 下面是我想要分裂的图像。
我正在试图分裂
这是我正在努力实现的。 想要的结果 。
不幸的是，我是新的stackoverflow，所以我的图像不会显示。 如果用户不希望点击链接，我会尝试通过其他方式解释：
我有不同的细胞，其中包含我想分裂的长string。 下面是我想要拆分的两行的示例。
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
预先感谢您的帮助！
编辑：更新和testing – 适用于您的“设置”数据
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
更容易将范围复制到Windows剪贴板并使用TSV文本格式（未经testing）：
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