Excel宏 - 逗号分隔单元格到行保留/聚合列 [英] Excel Macro - Comma Separated Cells to Rows Preserve/Aggregate Column

问题描述

我有一个类似的问题回答了这里

这种情况有一点点扭转，希望宏可以稍微改变一点。根据这些数据：

 < ;  -  A（类别） - > <  -  B（项目） - > 
 1 Cat1 a，b，c 
 2 Cat2 d 
 3 Cat3 e 
 4 Cat4 f，g 
  

我需要这样：

 <  -  A（类别） - > ; <  -  B（项目） - > 
 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 
 
'从列A复制到列B.'
 fromCol =A 
 toCol =B
 fromRow =1
 toRow =1
 
'直到不再有列A中的条目'
 inVal = Range（fromCol + fromRow）.Value 
当inVal<> 
 
'直到所有子条目都用完为止'
当inVal<> 
范围（fromCol + fromRow）。选择
 
'提取每个子条目'
 commaPos = InStr（1，inVal，，）
虽然逗号<> 0 
 
'并写入输出列'
 outVal = Left（inVal，commaPos  -  1）
范围（toCol + toRow）。选择
范围（toCol + toRow）.Value = outVal 
 toRow = Mid（Str（Val（toRow）+ 1），2）
 
'删除该子条目'
 inVal = Mid （inVal，commaPos + 1）
 While Left（inVal，1）=
 inVal = Mid（inVal，2）
 Wend 
 commaPos = InStr（1，inVal， 
范围（toCol + toRow）。选择
范围（$）
 Wend 
 
'获取最后一个子条目（toCol + toRow）.Value = inVal 
 toRow = Mid（Str（Val（toRow）+ 1），2）
 inVal =
 Wend 
 
 '进入下一个来源行'
 fromRow = Mid（Str（Val（fromRow）+ 1），2）
范围（fromCol + fromRow）。选择
 inVal = Range（fromCol + fromRow）.Value 
 Wend 
 End Sub 
  

解决方案

我认为这将适用于您：

  Sub ExpandData（）
 Const FirstRow = 2 
 Dim LastRow As Long 
 LastRow = Range（A& CStr（Rows.Count））。End（xlUp）.Row 
 
'从工作表中获取值
 Dim SourceRange As Range 
 Set SourceRange = Range（A& ; CStr（FirstRow）&：B& CStr（LastRow））
 
'获取数组值为
 Dim Vals（）As Variant 
 Vals = SourceRange .Value 
 
'循环遍历数组中的行，并分割每个逗号分隔的项目列表，并将其放在自己的行上
 Dim ArrIdx As Long 
 Dim RowCount As Long 
对于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 ，，）
 
 Dim ListIdx As Integer 
对于ListIdx = LBound（ListItems）到UBound（ListItems）
 
范围（A& CStr第一Row + RowCount））Value = CurrCat 
 Range（B& CStr（FirstRow + RowCount））Value = ListItems（ListIdx）
 RowCount = RowCount + 1 
 
下一个ListIdx 
 
下一个ArrIdx 
 
 End Sub 
  

I had a similar question answered Here

There is a slight twist to the scenario and hoping the macro can be changed slightly. Any help is appreciated.

Based on this Data:

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

I need this:

    <- 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

This is the existing Macro:

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

解决方案

I think this will work for you:

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宏 - 逗号分隔单元格到行保留/聚合列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！