[已解决]请高手帮忙看看问题出在哪了，在线等

mxg825

回复 commanding05a 的帖子

1. Private Sub CommandButton1_Click()
   
2.     Const BH As String = "物料名称"
   
3.     Const GG As String = "物料类型"
   
4.     Const NB As String = "合计数量"
   
5.     Const ZBNAME = "总表"
   
6.     Dim sh As Worksheet
   
7.     Dim rngTEMP, rngLast, temp, ggCell
   
8.     Dim fs, f, fl, fc, s, fls, flsE
   
9.     Dim WB As Workbook
   
10.     Dim She As Object
    
11.     Dim Rng As Range
    
12.     Dim MYrow&, MYcol
    
13.     Set fs = CreateObject("Scripting.FileSystemObject")  '创建FileSystemObject对象
    
14.     Set f = fs.GetFolder(ThisWorkbook.Path & "\分表") '创建文件夹对象
    
15.     Application.DisplayAlerts = False '临时关闭EXCEL 系统提示
    
16.     Application.ScreenUpdating = False
    
17.     On Error GoTo lab
    
18.     Set fls = f.Files '取得文件集合
    
19. With ThisWorkbook
    
20. Set ggCell = getCell(GG, .Sheets(ZBNAME)) '取得物料类型 总表 所在单元格
    
21.     Range(ggCell.Offset(1, -6), .Sheets(ZBNAME).Cells(65536, ggCell.Column)).Clear '清空旧数据
    
22.     For Each flsE In fls '历遍全部文件
    
23.        If InStr(flsE.Name, ".xls") > 0 Then ''避免打开非Excel文件
    
24.            Set WB = Workbooks.Open(flsE) '打开工作薄
    
25.            Set sh = WB.Sheets(1) '赋值分表 中 第一个工作表
    
26.            s = s + 1
    
27.             Set rngTEMP = getCell(GG, sh) '取得子表 物料类型 所以单元格
    
28.             Set temp = rngTEMP.Offset(1, 0) '上句的下一个单元格
    
29.                 Do While temp.Value <> ""
    
30.                     total = total + 1
    
31.                     ggCell.Offset(total, -5) = total '序号
    
32.                     ggCell.Offset(total, -6) = getCell(NB, sh).Offset(0, 1) '复制 合计数量
    
33.                     ggCell.Offset(total, -7) = getCell(BH, sh).Offset(0, 1) '复制 物料名称
    
34.                     
    
35.                     temp.Offset(0, -4).Resize(1, 5).Copy '复制 物料类型 区域
    
36.                     ggCell.Offset(total, -4).PasteSpecial Paste:=xlPasteValues
    
37.                      
    
38.                     Set temp = temp.Offset(1, 0)
    
39.                 Loop
    
40.            WB.Close False '关闭被打开工作薄
    
41.            Set WB = Nothing '释放对象
    
42.           End If
    
43.       Next
    
44.     MsgBox "共处理了" & s & "工作薄", 64, "提示"
    
45.     .Save '保存文件
    
46. End With
    
47. GoTo 100
    
48. lab:
    
49.     MsgBox "在总表或其它表中没有找到对应的字段！"
    
50. 100:
    
51. Set ggCell = Nothing
    
52. Set sh = Nothing
    
53. Application.ScreenUpdating = True
    
54. Application.DisplayAlerts = True
    
55. End Sub
    
56. Function getCell(str As String, sh As Worksheet) '查找子程序
    
57.     Set getCell = sh.Cells.Find(what:=str, lookat:=xlPart)
    
58. End Function
    

复制代码

commanding05a

回复 mxg825 的帖子

谢谢mxg825师兄，不胜感激，现在速度挺快的了，呵呵。
据说这种提取数据的方法用ADO也能实现，不知mxg825师兄是否了解，其实我就是想知道如果用ADO速度是不是能快些，哈哈

mxg825

把复制 几句代码：改成一个工作薄复制一次！
或用循环赋值法 应该速度会再快一点!