Excel VBA-将单元格字符串分割成单个单元格，并将单元格复制到新的单页 [英] Excel VBA- Split Cell Strings into individual cells and copy cells to new sheet

问题描述

我试图将单元格字符串拆分成一个Excel电子表格中的各个单元格，然后将新标题的拆分单元复制并粘贴到新的工作表中。以下是我想要分割的图像。

I am trying to split cell strings into various cells in one Excel spread sheet and then copy and paste the split cells with new headings into a new sheet. Below is the image of what I am trying to split.

我想要分解的内容

这是我正在努力实现的。
想要的结果。

Here is what I am trying to achieve. Wanted Outcome.

不幸的是我是新来的stackoverflow，所以我的图像不会显示。如果用户不希望单击链接，我将尝试用其他方法解释：

Unfortunately I am new to stackoverflow so my images wont show. If users do not wish to click the link I will try explain by other means:

我有各种单元格，其中包含我要分割的长字符串。
以下是我想拆分的两行的示例。

I have various cells which contain long strings which I am trying to split. Below is an example of two rows which I would like to split.

  Setup      |  MC 1: 1 x 18 , MC 2: 2 x 23 , MC 3: 2 x 32|
 ------------|----------------------------------------------
  Microphone |  2 x PHILIP DYNAMI SBMCMD                  |

（其中|表示列中断）

我想用以下标题拆分上面的内容，如下所示。

I would like to split the above with the following headers as shown below.

 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 |

以下代码适用于安装行。但是它不适用于麦克风行。它设法拆分正确的分隔符，但是它不针对包含麦克风数据的正确行。

The following code works for the setup rows. However it does not work for the microphone rows. It manages to split the correct delimiter, however it does not target the correct row containing the Microphone data.

    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

提前感谢您的帮助！

推荐答案

编辑：更新和测试 - 适用于您的设置数据

updated and tested - works for your "setup" data

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

这篇关于Excel VBA-将单元格字符串分割成单个单元格，并将单元格复制到新的单页的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！