|
再写一个,可以自动适配不同个数的仓库
- Sub test()
-
- Dim Arr, Brr(), Trr, Drr, Nrr() As Long
- Dim x&, y&, i&, j&, N&
- Dim k, d As Object
-
- With ThisWorkbook
- With .Sheets(1)
- x = .Cells(Rows.Count, 1).End(xlUp).Row
- Arr = .Range("a1").Resize(x, 8)
- End With
- Set d = CreateObject("Scripting.Dictionary")
- For i = 2 To UBound(Arr)
- d(Arr(i, 8)) = ""
- Next i
- Drr = d.keys
- Set d = Nothing
- ReDim Brr(0 To UBound(Arr) + 1, 1 To UBound(Drr) * 2 + 7)
- ReDim Nrr(0 To UBound(Drr))
-
- Set d = CreateObject("Scripting.Dictionary")
- For x = 2 To UBound(Arr)
- k = Arr(x, 1) & Arr(x, 2) & Arr(x, 3) & Arr(x, 4) & Arr(x, 5)
- d(k) = d(k) & x & ","
- Next
-
- For x = 1 To 5
- Brr(1, x) = Arr(1, x)
- Next
- For x = 0 To UBound(Drr)
- Brr(0, x * 2 + 6) = Drr(x)
- Brr(1, x * 2 + 6) = "单价"
- Brr(1, x * 2 + 7) = "数量"
- Next
-
- N = 1
- For Each k In d.keys
- Trr = Split(d(k), ",")
- For x = 0 To UBound(Nrr)
- Nrr(x) = N
- Next x
- For x = 0 To UBound(Trr) - 1
- i = Val(Trr(x))
- For y = 0 To UBound(Drr)
- If Arr(i, 8) Like Drr(y) Then
- Nrr(y) = Nrr(y) + 1
- If Nrr(y) > N Then N = Nrr(y)
- For j = 1 To 5
- Brr(Nrr(y), j) = Arr(i, j)
- Next j
- Brr(Nrr(y), y * 2 + 6) = Arr(i, 6)
- Brr(Nrr(y), y * 2 + 7) = Arr(i, 7)
- Exit For
- End If
- Next y
- Next x
- Erase Trr
- Next k
-
- With .Sheets(2)
- .Cells.Clear
- With .Range("a1").Resize(N + 1, UBound(Brr, 2))
- .Value = Brr
- .Borders.LineStyle = 1
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .Font.Size = 12
- End With
- For x = 0 To UBound(Drr)
- .Cells(1, x * 2 + 6).Resize(1, 2).Merge
- Next x
- End With
-
- End With
- Set d = Nothing
- Erase Arr
- Erase Brr
- Erase Drr
- Erase Nrr
-
- End Sub
复制代码 |
|