Question

请帮我提一下以下excel的一些建议。初始形式看起来像这样：

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

我想达到这个结果：

A    B     C
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

注意：我建议添加错误处理程序。有关详细信息，请参阅：Exception and Error Handling in Visual Basic

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

我不完全确定您是否需要对第三列进行排序，以防您添加排序功能。

Excel VBA - 逗号分隔单元格到行

3 个答案: