不同条目的一维转二维

titi012

参与一下。。。。。。

1. Sub test()
   
2.     Dim Arr, Brr(), Trr, x&, y&, i&, j&, N&, m&, H&, k, d As Object
   
3.     Arr = Range("a1").CurrentRegion
   
4.     ReDim Brr(1 To UBound(Arr), 1 To 9)
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     For x = 2 To UBound(Arr)
   
7.         k = Arr(x, 1) & Arr(x, 2) & Arr(x, 3) & Arr(x, 4) & Arr(x, 5)
   
8.         d(k) = d(k) & x & ","
   
9.     Next
   
10.     For Each k In d.keys
    
11.         Trr = Split(d(k), ",")
    
12.         j = N: i = N
    
13.         For x = 0 To UBound(Trr) - 1
    
14.             H = Val(Trr(x))
    
15.             If Arr(H, 8) Like "仓库1" Then
    
16.                 i = i + 1
    
17.                 For y = 1 To 7
    
18.                     Brr(i, y) = Arr(H, y)
    
19.                 Next y
    
20.             Else
    
21.                 j = j + 1
    
22.                 For y = 1 To 7
    
23.                     If y > 5 Then m = y + 2 Else m = y
    
24.                     Brr(j, m) = Arr(H, y)
    
25.                 Next y
    
26.             End If
    
27.         Next
    
28.         If i > j Then N = N + i Else N = N + j
    
29.     Next
    
30.     Range("j3").Resize(N, 9) = Brr
    
31. End Sub

复制代码

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.18
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("一维转二维")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 8)
   
8.     End With
   
9.     ReDim brr(1 To r, 1 To 100)
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.         d(s)(i) = i
    
14.     Next
    
15.     For Each k In d.keys
    
16.         m = t: n = t
    
17.         For Each kk In d(k).keys
    
18.             If arr(kk, 8) = "仓库1" Then
    
19.                 m = m + 1
    
20.                 For j = 1 To 5
    
21.                     brr(m, j) = arr(kk, j)
    
22.                 Next
    
23.                 brr(m, 6) = arr(kk, 6)
    
24.                 brr(m, 7) = arr(kk, 7)
    
25.             End If
    
26.             If arr(kk, 8) = "仓库2" Then
    
27.                 n = n + 1
    
28.                 For j = 1 To 5
    
29.                     brr(n, j) = arr(kk, j)
    
30.                 Next
    
31.                 brr(n, 8) = arr(kk, 6)
    
32.                 brr(n, 9) = arr(kk, 7)
    
33.             End If
    
34.         Next
    
35.         If m > n Then t = t + m Else t = t + n
    
36.     Next
    
37.     With Sheets("结果")
    
38.         .[a1].Resize(2, 9).Interior.Color = 49407
    
39.         With .[a3].Resize(t, 9)
    
40.             .Value = brr
    
41.             .Borders.LineStyle = 1
    
42.             .HorizontalAlignment = xlCenter
    
43.             .VerticalAlignment = xlCenter
    
44.         End With
    
45.         r = Cells(Rows.Count, 1).End(3).Row
    
46.         .UsedRange.Offset(r).Clear
    
47.     End With
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码

wang-way

ykcbf1100 发表于 2024-6-18 12:25
参与一下。。。

如果仓库数量不止2个呢？

笨鸟飞不高

ykcbf1100

wang-way 发表于 2024-6-18 13:38
如果仓库数量不止2个呢？

那就再改了。暂时没想到更好的办法。

sdytsxd991122

titi012

再写一个，可以自动适配不同个数的仓库

1. Sub test()
   
2.    
   
3.     Dim Arr, Brr(), Trr, Drr, Nrr() As Long
   
4.     Dim x&, y&, i&, j&, N&
   
5.     Dim k, d As Object
   
6.    
   
7.     With ThisWorkbook
   
8.         With .Sheets(1)
   
9.             x = .Cells(Rows.Count, 1).End(xlUp).Row
   
10.             Arr = .Range("a1").Resize(x, 8)
    
11.         End With
    
12.         Set d = CreateObject("Scripting.Dictionary")
    
13.         For i = 2 To UBound(Arr)
    
14.             d(Arr(i, 8)) = ""
    
15.         Next i
    
16.         Drr = d.keys
    
17.         Set d = Nothing
    
18.         ReDim Brr(0 To UBound(Arr) + 1, 1 To UBound(Drr) * 2 + 7)
    
19.         ReDim Nrr(0 To UBound(Drr))
    
20.    
    
21.         Set d = CreateObject("Scripting.Dictionary")
    
22.         For x = 2 To UBound(Arr)
    
23.             k = Arr(x, 1) & Arr(x, 2) & Arr(x, 3) & Arr(x, 4) & Arr(x, 5)
    
24.             d(k) = d(k) & x & ","
    
25.         Next
    
26.    
    
27.         For x = 1 To 5
    
28.             Brr(1, x) = Arr(1, x)
    
29.         Next
    
30.         For x = 0 To UBound(Drr)
    
31.             Brr(0, x * 2 + 6) = Drr(x)
    
32.             Brr(1, x * 2 + 6) = "单价"
    
33.             Brr(1, x * 2 + 7) = "数量"
    
34.         Next
    
35.    
    
36.         N = 1
    
37.         For Each k In d.keys
    
38.             Trr = Split(d(k), ",")
    
39.             For x = 0 To UBound(Nrr)
    
40.                 Nrr(x) = N
    
41.             Next x
    
42.             For x = 0 To UBound(Trr) - 1
    
43.                 i = Val(Trr(x))
    
44.                 For y = 0 To UBound(Drr)
    
45.                     If Arr(i, 8) Like Drr(y) Then
    
46.                         Nrr(y) = Nrr(y) + 1
    
47.                         If Nrr(y) > N Then N = Nrr(y)
    
48.                         For j = 1 To 5
    
49.                             Brr(Nrr(y), j) = Arr(i, j)
    
50.                         Next j
    
51.                         Brr(Nrr(y), y * 2 + 6) = Arr(i, 6)
    
52.                         Brr(Nrr(y), y * 2 + 7) = Arr(i, 7)
    
53.                         Exit For
    
54.                     End If
    
55.                 Next y
    
56.             Next x
    
57.             Erase Trr
    
58.         Next k
    
59.    
    
60.         With .Sheets(2)
    
61.             .Cells.Clear
    
62.             With .Range("a1").Resize(N + 1, UBound(Brr, 2))
    
63.                 .Value = Brr
    
64.                 .Borders.LineStyle = 1
    
65.                 .HorizontalAlignment = xlCenter
    
66.                 .VerticalAlignment = xlCenter
    
67.                 .Font.Size = 12
    
68.             End With
    
69.             For x = 0 To UBound(Drr)
    
70.                 .Cells(1, x * 2 + 6).Resize(1, 2).Merge
    
71.             Next x
    
72.         End With
    
73.         
    
74.     End With
    
75.     Set d = Nothing
    
76.     Erase Arr
    
77.     Erase Brr
    
78.     Erase Drr
    
79.     Erase Nrr
    
80.    
    
81. End Sub

复制代码

昵称不好起

数据透视表不就可以了吗

blackttea1

学习啦 ，谢谢分享