表格拆分

yaoguchao

原始数据有大约70万行，当前商品信息含商品编码和数量。要求：
原数据用“：”表示商品件数，用“；”间隔了商品条码，需要将这几个信息分开显示成每一行一个条码，将数量放到后面。
原表有70万行，用公式容易卡死，用VBA是否有较高效的方法。
原始数据：

订单	包裹号	时间	商品信息	重量	数量
111	A123	2018/7/7	690001:1	500	1
222	A321	2018/7/8	690002:2	400	2
333	A543	2018/7/8	690002:1;690007:1;5642:3	800	5

结果：

订单	包裹号	时间	商品信息	重量	数量
111	A123	2018/7/7	690001	500	1
222	A321	2018/7/8	690002	400	2
333	A543	2018/7/8	690002	160	1
333	A543	2018/7/8	690007	160	1
333	A543	2018/7/8	5642	480	3

一把小刀闯天下

Option Explicit

Sub test()
  Dim i As Long, j As Long, k As Long, arr, t, n As Long, cnt As Long
  arr = Sheets("原始数据").[a1].CurrentRegion
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2)) As String
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 4), ";") > 0 Then
      t = Split(arr(i, 4), ";"): cnt = 0
      ReDim crr(UBound(t))
      For j = 0 To UBound(t)
        crr(j) = Split(t(j), ":")
        cnt = cnt + Val(crr(j)(1))
      Next
      For j = 0 To UBound(t)
        n = n + 1
        For k = 1 To 3: brr(n, k) = arr(i, k): Next
        brr(n, 6) = crr(j)(1): brr(n, 4) = crr(j)(0)
        brr(n, 5) = arr(i, 5) / cnt * Val(crr(j)(1))
      Next
    Else
      n = n + 1
      For j = 1 To UBound(arr, 2): brr(n, j) = arr(i, j): Next
      brr(n, 4) = Split(brr(n, 4), ":")(0)
    End If
  Next
  With Sheets("结果").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

shaoshan

用数据分列效率不是比VBA效率要更高吗？

sdg1345

Sub ccc()
Dim arr(1 To 10, 1 To 6)

Sheet2.[h:m] = ""
a = Sheet1.Range("A1").CurrentRegion
n = 0
m = 0
For i = 2 To UBound(a)
    s = Split(a(i, 4), ";")
        m = n + 1
        For j = 0 To UBound(s)
            If UBound(s) > 0 Then
                st = 0
                For y = 0 To UBound(s)
                    st = st + Split(s(y), ":")(1)
                Next y
            Else
                st = 1
            End If
            If UBound(s) > 0 Then
                n = j + m
                arr(n, 1) = a(i, 1)
                arr(n, 2) = a(i, 2)
                arr(n, 3) = a(i, 3)
                arr(n, 4) = Split(s(j), ":")(0)
                arr(n, 5) = (Split(s(j), ":")(1) / st) * a(i, 5)
                arr(n, 6) = Split(s(j), ":")(1)
            Else
                n = j + m
                arr(n, 1) = a(i, 1)
                arr(n, 2) = a(i, 2)
                arr(n, 3) = a(i, 3)
                arr(n, 4) = Split(s(j), ":")(0)
                arr(n, 5) = a(i, 5)
                arr(n, 6) = a(i, 6)
            End If
        Next j
Next i
Sheet2.Range("h2").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub