Excel VBA – 逗号分隔的行到行

请帮助我一些关于下面的Excel的build议。 初始forms如下所示：

ABC 1 A1 ;100;200;300;400;500; 2 A2 ;716;721;428;1162;2183;433;434;1242;717;718; 3 A3 ;100;101; 

我想达到这个结果：

 ABC 1 A1 100 1 200 1 300 1 400 1 500 2 A2 716 2 721 2 428 2 1162 2 2183 2 433 2 434 2 1242 2 717 2 718 3 A3 100 3 101 

我尝试使用此代码，但它不会返回预期的结果。

 Sub SliceNDice() Dim objRegex As Object Dim X Dim Y Dim lngRow As Long Dim lngCnt As Long Dim tempArr() As String Dim strArr Set objRegex = CreateObject("vbscript.regexp") objRegex.Pattern = "^\s+(.+?)$" 'Define the range to be analysed X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2 ReDim Y(1 To 2, 1 To 1000) For lngRow = 1 To UBound(X, 1) 'Split each string by ";" tempArr = Split(X(lngRow, 2), ";") For Each strArr In tempArr lngCnt = lngCnt + 1 'Add another 1000 records to resorted array every 1000 records If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 2, 1 To lngCnt + 1000) Y(1, lngCnt) = X(lngRow, 1) Y(2, lngCnt) = objRegex.Replace(strArr, "$1") Next Next lngRow 'Dump the re-ordered range to columns C:D [c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) End Sub 

提前致谢！

Answer 1

尝试这个：

 Option Explicit Sub DoSomething() Dim i As Integer, j As Integer, k As Integer Dim srcwsh As Worksheet, dstwsh As Worksheet Dim sTmp As String, sNumbers() As String Set srcwsh = ThisWorkbook.Worksheets("Sheet1") Set dstwsh = ThisWorkbook.Worksheets("Sheet2") i = 1 j = 1 Do While srcwsh.Range("A" & i) <> "" sTmp = srcwsh.Range("C" & i) sNumbers = GetNumbers(sTmp) For k = LBound(sNumbers()) To UBound(sNumbers()) dstwsh.Range("A" & j) = srcwsh.Range("A" & i) dstwsh.Range("B" & j) = srcwsh.Range("B" & i) dstwsh.Range("C" & j) = sNumbers(k) j = j + 1 Next i = i + 1 Loop Set srcwsh = Nothing Set dstwsh = Nothing End Sub Function GetNumbers(ByVal sNumbers As String) As String() Dim sTmp As String sTmp = sNumbers 'remove first ; sTmp = Left(sTmp, Len(sTmp) - 1) 'remove last ;) sTmp = Right(sTmp, Len(sTmp) - 1) GetNumbers = Split(sTmp, ";") End Function 

注意：我build议添加error handling程序。 有关更多信息，请参阅： Visual Basic中的exception和error handling

Answer 2

此代码将为您工作

 Sub SplitAndCopy() Dim sh As Worksheet Set sh = ThisWorkbook.Worksheets("YourTargetSheet") Dim i As Long, j As Long, k As Long k = 2 For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row For j = LBound(Split(Range("C" & i).Value, ";")) + 1 To UBound(Split(Range("C" & i).Value, ";")) - 1 sh.Range("A" & k).Value = Range("A" & i).Value If j = LBound(Split(Range("C" & i).Value, ";")) + 1 Then sh.Range("B" & k).Value = Range("B" & i).Value End If sh.Range("C" & k).Value = Split(Range("C" & i).Value, ";")(j) k = k + 1 Next j Next i End Sub 

Answer 3

我宁愿这样做：

 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 

我不完全确定是否需要对第三列进行sorting，以防添加sortingfunction。