Question

我有一个数据，其中多个值在单个单元格中，我必须分别排列所有值。你能帮帮我吗？您的建议非常感谢。

我无法附加文件.. enter image description here

Countries   Cobination  Products    Q1 QUANTITY Q2 QUANTITY Q3 QUANTITY Q4 QUANTITY
USA First   Machine 90  340 600 900
Canada / USA / CHINA    First   Computer , Vehicles , Households    80  112 112 34
BRAZIL , CHINA , SA     BOOKS   10  600 0   698
CANADA  Second  BOTTLES / CARPET    4000    3243        4449

结果如下所示

Countries       Products    Q1 QUANTITY Q2 QUANTITY Q3 QUANTITY Q4 QUANTITY
USA First   Machine 90  340 600 900
Canada  First   Computer    80  112 112 34
USA First   Computer    80  112 112 34
CHINA   First   Computer    80  112 112 34
Canada  First   Vehicles    80  112 112 34
USA First   Vehicles    80  112 112 34
CHINA   First   Vehicles    80  112 112 34
Canada  First   Households  80  112 112 34
USA First   Households  80  112 112 34
CHINA   First   Households  80  112 112 34
BRAZIL      BOOKS   10  600 0   698
CHINA       BOOKS   10  600 0   698
SA      BOOKS   10  600 0   698
CANADA  Second  BOTTLES 4000    3243        4449
CANADA  Second  CARPET  4000    3243        4449

Answer 1

检查一下，这可能不是最佳解决方案。我用了3个程序。

Cell3_Count（）：要知道要从cell1和cell3中的字符串组合中插入的行数。
split_cell3（）：根据分隔符拆分单元格值。
ArrangeBasedOnValues（）：同时具有cell1和输出的1.和2.功能。

请检查不同的情况，并在必要时进行必要的更改。

选项明确选项比较文本

Public sht1 As Worksheet，i As Long，j As Long，lastrow1 As Long，k As Long，l As Long Public str1 As String，str2（）As String，str3（）As String，str4 As String，s1 As String，s2 As String，s3 As String，s4 As String Public cnt1 As String，cnt2 As Integer，ncells As Integer

Sub ArrangeBasedOnValues（）

Set sht1 = ThisWorkbook.Worksheets(1)

'Starting row
i = 6

next_cell：

lastrow1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row

Do While (i <= lastrow1)

    str1 = sht1.Cells(i, 1).Value

    str4 = sht1.Cells(i, 3).Value

    s1 = "/"

    s2 = ","

    cnt1 = 0

    'Check number of strings in cell1
    If InStr(1, str1, s1, vbTextCompare) > 0 Then

        s4 = s1

        'count of special characters in cell1
        cnt1 = Len(str1) - Len(Replace(str1, s1, ""))

        Call Cell3_Count

    ElseIf InStr(1, str1, s2, vbTextCompare) > 0 Then

        s4 = s2

        cnt1 = Len(str1) - Len(Replace(str1, s2, ""))

        Call Cell3_Count

    Else

        Call Cell3_Count

    End If

    'combination of elements in cell1 and cell3
    'cnt1+1 : Total numbers of strings = total number of spl chars + 1
    ncells = ((cnt1 + 1) * (cnt2 + 1)) - 1

    'Only one string in cell1
    If ncells = 1 Then

        'Add extra rows based on the combination
        sht1.Rows(i + 1 & ":" & i + ncells).Insert Shift:=xlDown, _
        CopyOrigin:=xlFormatFromLeftOrAbove

        sht1.Cells(i + 1, 1).Value = sht1.Cells(i, 1).Value

        sht1.Range("B" & i + 1).Value = Trim(sht1.Range("B" & i).Value)

        sht1.Range("D" & i & ":" & "G" & i).Copy sht1.Range("D" & i + 1 & ":" & "G" & i + 1)

        Call split_cell3

    'more than one string
    ElseIf ncells > 1 Then

        sht1.Rows(i + 1 & ":" & i + ncells).Insert Shift:=xlDown, _
        CopyOrigin:=xlFormatFromLeftOrAbove

        Dim q As Integer

        q = i

        str2 = Split(str1, s4)

        For k = LBound(str2) To UBound(str2)

            'UBound(str2) + 1 : number of times each string in cell4 needs to be printed

            For l = q To i + ncells Step UBound(str2) + 1

                sht1.Cells(l, 1).Value = Trim(str2(k))

                sht1.Range("B" & l).Value = Trim(sht1.Range("B" & i).Value)

                'cnt2=0 : only one string in cell3
                If cnt2 = 0 Then

                    sht1.Range("C" & i & ":" & "G" & i).Copy sht1.Range("C" & l & ":" & "G" & l)

                'More than one string in cell3
                Else

                    sht1.Range("D" & i & ":" & "G" & i).Copy sht1.Range("D" & l & ":" & "G" & l)

                End If

            Next l

            q = q + 1

        Next k

        'cnt2>0 : need to split strings in cell3
        If cnt2 > 0 Then

            Call split_cell3

        End If

        i = i + ncells + 1

        GoTo next_cell

    'Only one string in both cell1 and cell3
    Else

        i = i + 1

        GoTo next_cell

    End If

    i = i + ncells + 1

    lastrow1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row

Loop

End Sub 'cell3中的字符串数 Sub Cell3_Count（）

cnt2 = 0

'Check number of values
If InStr(1, str4, s1, vbTextCompare) > 0 Then

    s3 = s1

    'count of special characters in cell3
    cnt2 = Len(str4) - Len(Replace(str4, s1, ""))

ElseIf InStr(1, str4, s2, vbTextCompare) > 0 Then

    s3 = s2

    cnt2 = Len(str4) - Len(Replace(str4, s2, ""))

End If

End Sub

'根据在cell3_count中获得的分隔符，在cell3中拆分字符串 Sub split_cell3（）

str3() = Split(str4, s3)

Dim m As Integer, n As Integer

m = i

'Debug.Print cnt1 + 1

For n = LBound(str3) To UBound(str3)

    For l = m To m + cnt1

        sht1.Range("C" & l).Value = Trim(str3(n))

    Next l

    m = m + cnt1 + 1

Next n

End Sub

如果多个值在单个单元格中，则在vba中创建多个行

1 个答案: