[已解决]每月盘点表快速汇总

monit

求一段代码,实现每月盘点表快速汇总,谢谢

最佳答案

月排行榜 / 总排行榜

grf1973

2016-3-11 16:59

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, ThisSh As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set ThisSh = ActiveSheet
   
6.     ThisSh.Range("a2:h65536").ClearContents
   
7.     Do While Filename <> ""
   
8.         If Filename <> ThisWorkbook.Name Then
   
9.             fn = ThisWorkbook.Path & "" & Filename
   
10.             Set wb = Workbooks.Open(fn)
    
11.             mc = wb.Worksheets(1).[a9]
    
12.             For i = 2 To 8
    
13.                 If i = 5 Or i = 8 Then tj = "特价" Else tj = "正价"
    
14.                 Set Sht = wb.Worksheets(i)
    
15.                 r = ThisSh.UsedRange.Rows.Count + 1
    
16.                 ThisSh.Cells(r, 1).Resize(34, 6).Value = Sht.[b7:g40].Value
    
17.                 r = ThisSh.UsedRange.Rows.Count + 1
    
18.                 ThisSh.Cells(r, 1).Resize(34, 6).Value = Sht.[k7:r40].Value
    
19.                 r = ThisSh.UsedRange.Rows.Count + 1
    
20.                 r1 = ThisSh.[g65536].End(3).Row + 1
    
21.                 ThisSh.Cells(r1, "g").Resize(r - r1).Value = mc
    
22.                 ThisSh.Cells(r1, "h").Resize(r - r1).Value = tj
    
23.             Next
    
24.             wb.Close False
    
25.         End If
    
26.         Filename = Dir
    
27.     Loop
    
28.     Set Sht = Nothing
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, ThisSh As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set ThisSh = ActiveSheet
   
6.     ThisSh.Range("a2:h65536").ClearContents
   
7.     Do While Filename <> ""
   
8.         If Filename <> ThisWorkbook.Name Then
   
9.             fn = ThisWorkbook.Path & "" & Filename
   
10.             Set wb = Workbooks.Open(fn)
    
11.             mc = wb.Worksheets(1).[a9]
    
12.             For i = 2 To 8
    
13.                 If i = 5 Or i = 8 Then tj = "特价" Else tj = "正价"
    
14.                 Set Sht = wb.Worksheets(i)
    
15.                 r = ThisSh.UsedRange.Rows.Count + 1
    
16.                 ThisSh.Cells(r, 1).Resize(34, 6).Value = Sht.[b7:g40].Value
    
17.                 r = ThisSh.UsedRange.Rows.Count + 1
    
18.                 ThisSh.Cells(r, 1).Resize(34, 6).Value = Sht.[k7:r40].Value
    
19.                 r = ThisSh.UsedRange.Rows.Count + 1
    
20.                 r1 = ThisSh.[g65536].End(3).Row + 1
    
21.                 ThisSh.Cells(r1, "g").Resize(r - r1).Value = mc
    
22.                 ThisSh.Cells(r1, "h").Resize(r - r1).Value = tj
    
23.             Next
    
24.             wb.Close False
    
25.         End If
    
26.         Filename = Dir
    
27.     Loop
    
28.     Set Sht = Nothing
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

monit

grf1973 发表于 2016-3-11 16:59

完美解决问题,谢谢老师