Excelmacros – 逗号分隔单元行保留/聚合列

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

这种情况有一些轻微的转变，希望macros观可以稍微改变。 任何帮助表示赞赏。

基于这个数据：

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

这是现有的macros：

 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