数据汇总

yynrzwh

1. Sub 汇总()
   
2. 
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ph = ThisWorkbook.Path & ""
   
5. nm = Split(ThisWorkbook.Name, ".")(0)
   
6. f = Dir(ph & "*.xls")
   
7. Application.ScreenUpdating = False
   
8.     Do While f <> ""
   
9.         If InStr(f, nm) = 0 Then
   
10.             With Workbooks.Open(ph & f, 0)
    
11.                 arr = .Sheets(1).UsedRange
    
12.                 .Close False
    
13.             End With
    
14.             For i = 2 To UBound(arr)
    
15.                 s = arr(i, 15)
    
16.                 If Len(s) <> 0 Then
    
17.                     sl = arr(i, 22)
    
18.                     If InStr(sl, ".") Then sl = Replace(arr(i, 22), ".", "") * 1
    
19.                     If d.exists(s) Then
    
20.                         d(s) = d(s) + sl
    
21.                     Else
    
22.                         d(s) = sl
    
23.                     End If
    
24.                 End If
    
25.             Next i
    
26.             
    
27.             With Sheets(1)
    
28.                 lc = .Cells(2, Columns.Count).End(xlToLeft).Column
    
29.                 If lc > 1 Then lc = lc + 1
    
30.                 .Cells(1, lc) = Split(f, ".")(0)
    
31.                 .Cells(2, lc) = "规格": .Cells(2, lc + 1) = "数量"
    
32.                 .Cells(3, lc).Resize(d.Count) = Application.Transpose(d.keys)
    
33.                 .Cells(3, lc + 1).Resize(d.Count) = Application.Transpose(d.items)
    
34.             End With
    
35.             d.RemoveAll
    
36.         End If
    
37.         f = Dir
    
38.     Loop
    
39. 
    
40. Application.ScreenUpdating = True
    
41. Set d = Nothing
    
42. MsgBox "运行完毕！"
    
43. End Sub
    

复制代码