逗号将单元格分隔为行,但保留周围列中的数据

时间:2011-01-17 21:37:27

标签: excel vba csv excel-vba

Excel Macro - Comma Separated Cells to Rows Preserve/Aggregate Column

我的问题与上面的链接几乎完全一样,除了我想要突破的列数据如下:

 <- A (Category) ->   <- B (Items) -> <- B (Items) -> <- B (Items) -> <- B (Items) ->
  1   Cat1                 date1          a,b,c            a1,b1,c1        item1
  2   Cat2                 date2           d                  d1           item2
  3   Cat3                 date3           e,f                e1,f1        item3
  4   Cat4                 date4           g                  g1           item4

我想要的是:

 <- A (Category) ->   <- B (Items) -> <- C (Items) -> <- D (Items) -> <- E (Items) ->
  1   Cat1                 date1           a                  a1           item1
  1   Cat1                 date1           b                  b1           item1
  1   Cat1                 date1           c                  c1           item1
  2   Cat2                 date2           d                  d1           item2
  3   Cat3                 date3           e                  e1           item3
  3   Cat3                 date3           f                  f1           item3 
  4   Cat4                 date4           g                  g1           item4

我想将C列和D列拆分为新行并复制A,B和E中的项目。实际上有更多列,但我这样做是为了让它更容易。

以下代码仅适用于2个相邻列。我想知道是否可以输入一系列列进行复制?

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

1 个答案:

答案 0 :(得分:0)

立即简化是

 Set SourceRange = [A1].CurrentRegion

对于其他人来说,看起来你正处于正确的轨道上,但你想改变ListItems ...逻辑来设置一个布尔值来告诉你拆分其他列。

你最终得到了一个If Then Else,其中一方处理简单的行和 处理多项目行的另一方。更多代码,但简单且不太可能存在错误。