Question

我有一个类似的问题已经回答Here

方案略有不同，希望可以略微改变宏。任何帮助表示赞赏。

基于此数据：

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a,b, c
2   Cat2                 d
3   Cat3                 e
4   Cat4                 f, g

我需要这个：

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a
2   Cat1                 b
3   Cat1                 c
4   Cat2                 d
5   Cat3                 e
6   Cat4                 f
7   Cat4                 g

这是现有的宏：

Option Explicit
Sub Macro1()
    Dim fromCol As String
    Dim toCol As String
    Dim fromRow As String
    Dim toRow As String
    Dim inVal As String
    Dim outVal As String
    Dim commaPos As Integer

    ' Copy from column A to column B.'
    fromCol = "A"
    toCol = "B"
    fromRow = "1"
    toRow = "1"

    ' Go until no more entries in column A.'
    inVal = Range(fromCol + fromRow).Value
    While inVal <> ""

        ' Go until all sub-entries used up.'
        While inVal <> ""
            Range(fromCol + fromRow).Select

            ' Extract each subentry.'
            commaPos = InStr(1, inVal, ",")
            While commaPos <> 0

                ' and write to output column.'
                outVal = Left(inVal, commaPos - 1)
                Range(toCol + toRow).Select
                Range(toCol + toRow).Value = outVal
                toRow = Mid(Str(Val(toRow) + 1), 2)

                ' Remove that sub-entry.'
                inVal = Mid(inVal, commaPos + 1)
                While Left(inVal, 1) = " "
                    inVal = Mid(inVal, 2)
                Wend
                commaPos = InStr(1, inVal, ",")
            Wend

            ' Get last sub-entry (or full entry if no commas).'
            Range(toCol + toRow).Select
            Range(toCol + toRow).Value = inVal
            toRow = Mid(Str(Val(toRow) + 1), 2)
            inVal = ""
        Wend

        ' Advance to next source row.'
        fromRow = Mid(Str(Val(fromRow) + 1), 2)
        Range(fromCol + fromRow).Select
        inVal = Range(fromCol + fromRow).Value
    Wend
End Sub

Answer 1

我认为这对你有用：

Sub ExpandData()
    Const FirstRow = 2
    Dim LastRow As Long
    LastRow = Range("A" & CStr(Rows.Count)).End(xlUp).Row

    ' Get the values from the worksheet
    Dim SourceRange As Range
    Set SourceRange = Range("A" & CStr(FirstRow) & ":B" & CStr(LastRow))

    ' Get sourcerange values into an array
    Dim Vals() As Variant
    Vals = SourceRange.Value

    ' Loop through the rows in the array and split each comma-delimited list of items and put each on its own row
    Dim ArrIdx As Long
    Dim RowCount As Long
    For ArrIdx = LBound(Vals, 1) To UBound(Vals, 1)

        Dim CurrCat As String
        CurrCat = Vals(ArrIdx, 1)

        Dim CurrList As String
        CurrList = Replace(Vals(ArrIdx, 2), " ", "")

        Dim ListItems() As String
        ListItems = Split(CurrList, ",")

        Dim ListIdx As Integer
        For ListIdx = LBound(ListItems) To UBound(ListItems)

            Range("A" & CStr(FirstRow + RowCount)).Value = CurrCat
            Range("B" & CStr(FirstRow + RowCount)).Value = ListItems(ListIdx)
            RowCount = RowCount + 1

        Next ListIdx

    Next ArrIdx

End Sub

Excel宏 - 逗号分隔单元格到行保留/聚合列

1 个答案: