Excel VBA – 逗号分隔单元格到行
查找VBA代码，将包含一列逗号分隔值的dynamic表转换为不含逗号分隔值的表。 列有标题，可以使用命名的范围来标识表和列。 “给定数据”中可能有任意数量的这些值。 所以在这个例子中有4行数据，但实际上数据的范围可以从1到300行以上。
给定数据（“Sheet1”）：
ABCD CPN: MPN: Price: Text: CPN1, CPN2, CPN3 MPN1 1.25 Example1 CPN4, CPN6 MPN5 3.50 Example2 CPN7 MPN4 4.20 Example3 CPN8, CPN9 MPN2 2.34 Example4 我需要的结果是另一张纸上的表格，让我们只说“Sheet2”，用“A”中的每个逗号分隔的行以及来自原始工作表的相应数据，而不删除第一个工作表中的数据。
所需结果（“Sheet2”）：
ABCD CPN: MPN: Price: Text: CPN1 MPN1 1.25 Example1 CPN2 MPN1 1.25 Example1 CPN3 MPN1 1.25 Example1 CPN4 MPN5 3.50 Example2 CPN6 MPN5 3.50 Example2 CPN7 MPN4 4.20 Example3 CPN8 MPN2 2.34 Example4 CPN9 MPN2 2.34 Example4
我已经尝试从这里修改下面的代码，但无法得到它来处理我的值types。 任何帮助将不胜感激。
Private Type data col1 As Integer col2 As String col3 As String End Type Sub SplitAndCopy() Dim x%, y%, c% Dim arrData() As data Dim splitCol() As String ReDim arrData(1 To Cells(1, 1).End(xlDown)) x = 1: y = 1: c = 1 Do Until Cells(x, 1) = "" arrData(x).col1 = Cells(x, 1) arrData(x).col2 = Cells(x, 2) arrData(x).col3 = Cells(x, 3) x = x + 1 Loop [a:d].Clear For x = 1 To UBound(arrData) Cells(c, 2) = arrData(x).col2 splitCol = Split(Mid(arrData(x).col3, 2, Len(arrData(x).col3) - 2), ",") ' sort splitCol For y = 0 To UBound(splitCol) Cells(c, 1) = arrData(x).col1 Cells(c, 3) = splitCol(y) c = c + 1 Next y Next x End Sub
Public Sub textToColumns() Set ARange = Range("A:A") Set BRange = Range("B:B") Set CRange = Range("C:C") Set DRange = Range("D:D") Dim arr() As String lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set out = Worksheets.Add out.Name = "out" outRow = 2 For i = 2 To lr arr = Split(ARange(i), ",") For j = 0 To UBound(arr) out.Cells(outRow, 1) = Trim(arr(j)) out.Cells(outRow, 2) = BRange(i) out.Cells(outRow, 3) = CRange(i) out.Cells(outRow, 4) = DRange(i) outRow = outRow + 1 Next j Next i End Sub
我没有做标题或处理正确的输出表，但你可以看到基本上是怎么回事。
Option Explicit Public Sub denormalizeCSV() Const FR As Byte = 2 'first row Const DELIM As String = "," Dim ws As Worksheet, lr As Long, lc As Long, i As Long, j As Long Dim arr As Variant, thisVal As String, itms As Long Set ws = Worksheets(1) lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column Application.ScreenUpdating = False With ws i = FR Do thisVal = .Cells(i, 1).Value2 If InStr(thisVal, DELIM) > 0 Then thisVal = Replace(thisVal, " ", vbNullString) arr = Split(thisVal, DELIM) itms = UBound(arr) + 1 .Rows(i + 1 & ":" & i + itms - 1).Insert Shift:=xlDown .Range(.Cells(i, 2), .Cells(i, lc)).Copy For j = i + 1 To i + itms - 1 .Range(.Cells(j, 2), .Cells(j, lc)).PasteSpecial xlPasteValues Next .Range(.Cells(i, 1), .Cells(i + itms - 1, 1)) = Application.Transpose(arr) i = i + itms Else i = i + 1 End If Loop Until Len(.Cells(i, 1).Value2) = 0 End With Application.ScreenUpdating = True End Sub
testing结果：
