|
本帖最后由 lichuanboy44 于 2016-5-6 21:25 编辑
跨工作簿导入汇总,我较熟悉,可能是这样吧。本程序正确运行的前提是销售总额至销售笔数这6个表的结构完全一模一样,保证每个店都在各表的同一行,减轻程序编制难度。
注:再次编辑,并人为加了两个店的副本,以便程序进行错误识别。- Sub test2()
- Dim p%, f, a, r%, i%, path, n%, cr
- Application.ScreenUpdating = False
- On Error Resume Next
- tb = Timer
- Set d = CreateObject("scripting.dictionary")
- '1、将本簿“销售总额”表的B列的店名所在行数存入字典中,以便写入数据时用
- '其它表店名顺序和所在行数必须和“销售总额”一致,否则自己修改。
- n = Worksheets(1).[B65536].End(3).Row
- ar = Worksheets(1).Range("B4:B" & n)
- c = 1: ReDim cr(1 To c) 'cr数组专用于存放TTL汇总店名中没有的店(工作簿),以便提醒
- Worksheets(7).[A2:AH2000].ClearContents
- For i = 1 To n - 3
- a = ar(i, 1)
- If a <> "" And Not a Like "*小计*" And Not a Like "*合计*" And Not a Like "*累计*" Then
- d(a) = i + 3
- End If
- Next
- '2)依次打开工作簿,读取每表B3:G33固定区域的数据
- path = ThisWorkbook.path & ""
- f = Dir(path & "*.xls*")
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- With Workbooks.Open(path & f)
- br = .Worksheets(1).[B3:G33]
- wn = .Name
- .Close False
- End With
- wn2 = Left(wn, InStr(wn, ".xls") - 1)
- If d.exists(wn2) Then
- r = d(wn2) '写入的第几行
- Else
- ReDim Preserve cr(1 To c)
- cr(c) = wn2
- 'MsgBox "汇总表中无" & wn2 & "工作簿,请审核"
- c = c + 1
- End If
- For i = 1 To 6
- Worksheets(i).Range("C" & r).Resize(1, 31) = _
- WorksheetFunction.Transpose(WorksheetFunction.Index(br, 0, i))
- Next
- With Worksheets(7)
- nn = .[B65536].End(3).Row: If nn = 0 Then nn = 1
- .Range("B" & nn + 1).Resize(6, 31) = WorksheetFunction.Transpose(br)
- .Range("A" & nn + 1 & ":A" & nn + 6) = wn2
- End With
- p = p + 1
- End If
- f = Dir
- Loop
- With Worksheets(1) '将TTL汇总店名中没有的店,写入“销售总额”表的最后,以便提醒。
- .Range("B" & n + 2).Resize(300, 1).ClearContents
- .Range("B" & n + 2) = "以下店的数据未导入:"
- .Range("B" & n + 3).Resize(UBound(cr), 1) = WorksheetFunction.Transpose(cr)
- End With
- tn = Timer - tb
- [D1] = Format(tn, "0.00秒")
- Application.ScreenUpdating = True
- MsgBox "本次运行耗时" & Format(tn, "0.00秒") & "/共成功导入" & p - c + 1 & "个店(工作簿)的数据" & vbCrLf & _
- "提醒:有" & c - 1 & "个店数据未导入,具体情况请在“销售总额”表尾查看"
- Worksheets(1).Activate
- Worksheets(1).Range("B" & n + 2).Select
- End Sub
复制代码 |
|