求助用VBA for循环+数组整理库存表

hefuqing

以下表 求大神用VBA for循环+数组整理成后面这个格式第一行是尺码

货号	COLOR	104	116	128	140	152	164	176
R802-5204	099			14			13	9
R802-5204	099				21	16
R802-5301	099			13		11	8	8
R802-5301	099				18
R802-5303	700			16
R802-5303	700				19	9
R802-5303	700						8	8
R802-5306	099			14		12
R802-5306	099				20		10	7
R802-5307	375					11	13
R802-5307	375			16	18			10
R802-5307	200			17	15	11		9
R802-5307	200						11
R802-5601	375			14	19	14	9	8
R802-5601	099			13	19	14	9	8
R802-5703	099			16
R802-5801	700			15	16	13	14	8
R802-5703	099				23	13	9

货号+尺码+颜色	数量
R802-5204099104	25
R802-5204099104	25
R802-5204099104	25
R802-5204099104	25
R802-5204099104	25
R802-5204099104	25
R802-5204099104	25

一把小刀闯天下

'猜一个，好像你自己给自己挖了一个坑

Option Explicit

Sub test()
  Dim arr, i, j, t, n
  arr = Sheets("数据").[a1].CurrentRegion
  ReDim brr(1 To Rows.Count, 1 To 2)
  For i = 2 To UBound(arr, 1)
    t = arr(i, 1) & arr(i, 2)
    For j = 3 To UBound(arr, 2)
      If Len(arr(i, j)) Then
        n = n + 1
        brr(n, 1) = t & arr(1, j): brr(n, 2) = arr(i, j)
      End If
  Next j, i
  With Sheets("汇总").[d2] '输出位置自己修改
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

jnsxmt

1. Sub test()
   
2.     Dim ar, br(), m&, n&, k&
   
3.     ar = Worksheets("数据").UsedRange
   
4.     For m = 2 To UBound(ar, 1)
   
5.         For n = 3 To UBound(ar, 2)
   
6.             If ar(m, n) <> "" Then
   
7.                 k = k + 1
   
8.                 ReDim Preserve br(1 To 2, 1 To k)
   
9.                 br(1, k) = ar(m, 1) & ar(m, 2) & ar(1, n)
   
10.                 br(2, k) = ar(m, n)
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     Worksheets("汇总").[a2].Resize(k, 2) = Application.Transpose(br)
    
15. End Sub
    

复制代码

microyip

一把小刀闯天下 发表于 2018-8-2 15:41
'猜一个，好像你自己给自己挖了一个坑

Option Explicit

你没有给自己挖坑，只是搬了个石头，准备砸脚趾，哈哈

hefuqing

microyip 发表于 2018-8-2 16:07
你没有给自己挖坑，只是搬了个石头，准备砸脚趾，哈哈

哪里是坑呢

hefuqing

microyip 发表于 2018-8-2 16:07
你没有给自己挖坑，只是搬了个石头，准备砸脚趾，哈哈

哪里是坑呢

gdfcx

好久不写了，参与一下：

1. Sub 宏2()
   
2.     Dim i, j, arr, d As Object
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.[a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         For j = 3 To UBound(arr, 2)
   
8.             If arr(i, j) <> "" Then
   
9.                 d(arr(i, 1) & arr(i, 2) & arr(1, j)) = d(arr(i, 1) & arr(i, 2) & arr(1, j)) + arr(i, j)
   
10.             End If
    
11.         Next j
    
12.     Next i
    
13.     With Sheets("汇总")
    
14.         .[a1].CurrentRegion.Clear
    
15.         .[a1] = "货号+尺码+颜色"
    
16.         .[b1] = "数量"
    
17.         .[a2].Resize(d.Count) = Application.Transpose(d.Keys)
    
18.         .[b2].Resize(d.Count) = Application.Transpose(d.items)
    
19.     End With
    
20.     Set d = Nothing
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "汇总完毕！"
    
23. End Sub

复制代码

hefuqing

jnsxmt 发表于 2018-8-2 15:55

大神 追问下  如果货号+颜色+尺码相同的需要合并数量 需要怎么修改呢