|
- Sub XXX()
- On Error Resume Next
- Dim arr, brr, Sht As Worksheet
- arr = Sheet1.UsedRange
- ReDim brr(1 To 4 ^ 8, 1 To UBound(arr, 2))
- For x = 1 To UBound(arr, 2)
- brr(1, x) = arr(1, x)
- Next
- b = 1
- For a = 2 To UBound(arr)
- b = b + Val(arr(a, 4))
- For x = b - Val(arr(a, 4)) + 1 To b
- For bb = 1 To UBound(brr, 2)
- brr(x, bb) = arr(a, bb)
- Next
- Next
- srr = Split(arr(a, 3), ",")
- For s = 0 To UBound(srr)
- brr(b - Val(arr(a, 4)) + 1 + s, 3) = srr(s)
- Next
- Next
- Err.clear:Set Sht = Sheets("结果")
- If Err.Number <> 0 Then
- Sheets.Add.Name = "结果"
- Set Sht = Sheets("结果")
- End If
- Sht.Cells.ClearContents
- Sht.[a1].Resize(b, UBound(arr, 2)) = brr
- End Sub
复制代码 |
|