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

commanding05a

即要实现不打开原EXCEL文件，因为太多了，而从每个源文件中根据条件读取数据到总表中
Private Sub CommandButton1_Click()
    Const BH As String = "物料名称"
    Const GG As String = "物料类型"
    Const NB As String = "合计数量"
    Const ZBNAME = "总表"
    Dim sh As Worksheet
    Dim rngTEMP, rngLast, temp, ggCell
    Dim fs, f, fl, fc, s, fls, flsE
    Dim WB As Workbook
    Dim She As Object
    Dim Rng As Range
    Dim WBrow&, MYcol
    Set fs = CreateObject("Scripting.FileSystemObject")  '创建FileSystemObject对象
    Set f = fs.GetFolder(ThisWorkbook.Path & "\分表\") '创建文件夹对象
    Application.DisplayAlerts = False '临时关闭EXCEL 系统提示
    Application.ScreenUpdating = False
    On Error GoTo lab
    Set ggCell = getCell(GG, ThisWorkbook.Sheets(ZBNAME))
    Range(ggCell.Offset(1, -6), ThisWorkbook.Sheets(ZBNAME).Cells(65536, ggCell.Column)).Clear
    Set fls = f.Files '取得文件集合
With ThisWorkbook
    For Each flsE In fls '历遍全部文件
       If InStr(flsE.Name, ".xls") > 0 Then ''避免打开非Excel文件
           Set WB = Workbooks.Open(flsE) '打开工作薄
           s = s + 1
            Set rngTEMP = getCell(GG, sh)
            Set temp = rngTEMP.Offset(1, 0)
                Do While temp.Value <> ""
                    total = total + 1
                    Set rngLast = ThisWorkbook.Sheets(ZBNAME).Cells(65536, ggCell.Column).End(xlUp)
                    temp.Offset(0, -4).Resize(1, 5).Copy
                    rngLast.Offset(1, -4).PasteSpecial Paste:=xlPasteValues
                    rngLast.Offset(1, -5) = total
                    getCell(NB, sh).Offset(0, 1).Copy
                    rngLast.Offset(1, -6).PasteSpecial Paste:=xlPasteValues
                    getCell(BH, sh).Offset(0, 1).Copy
                    rngLast.Offset(1, -7).PasteSpecial Paste:=xlPasteValues
                    Set temp = temp.Offset(1, 0)
                Loop
           WB.Close False '关闭被打开工作薄
           Set WB = Nothing '释放对象
lab:
    MsgBox "在总表或其它表中没有找到对应的字段！"
    Set ggCell = Nothing
    Set sh = Nothing
        End If
    Next
.Save '保存文件
End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共处理了" & s & "工作薄", 64, "提示"
End Sub
Function getCell(str As String, sh As Worksheet)
    Set getCell = sh.Cells.Find(what:=str, lookat:=xlPart)
End Function
请高手帮忙！！

最佳答案

月排行榜 / 总排行榜

mxg825

2011-10-10 14:21

回复 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
    

复制代码

跳转到最佳答案楼层

mxg825

出错问题在哪里？
上传几个表，调试一下！

commanding05a

回复 mxg825 的帖子


以上是几个例子，请MXG825兄帮忙，谢谢了先

mxg825

没有总表 ？

commanding05a

回复 mxg825 的帖子

请MXG825兄帮忙，谢谢了先
汇总1.zip (12.55 KB, 下载次数: 9)

2011-10-10 13:15 上传

点击文件名下载附件

commanding05a

回复 commanding05a 的帖子

总表已上传，请帮忙解决！

mxg825

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 WBrow&, 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.                     Set rngLast = .Sheets(ZBNAME).Cells(65536, ggCell.Column).End(xlUp)
    
32.                     temp.Offset(0, -4).Resize(1, 5).Copy
    
33.                     rngLast.Offset(1, -4).PasteSpecial Paste:=xlPasteValues
    
34.                     rngLast.Offset(1, -5) = total
    
35.                     getCell(NB, sh).Offset(0, 1).Copy
    
36.                     rngLast.Offset(1, -6).PasteSpecial Paste:=xlPasteValues
    
37.                     getCell(BH, sh).Offset(0, 1).Copy
    
38.                     rngLast.Offset(1, -7).PasteSpecial Paste:=xlPasteValues
    
39.                     Set temp = temp.Offset(1, 0)
    
40.                 Loop
    
41.            WB.Close False '关闭被打开工作薄
    
42.            Set WB = Nothing '释放对象
    
43.           End If
    
44.       Next
    
45.     MsgBox "共处理了" & s & "工作薄", 64, "提示"
    
46.     .Save '保存文件
    
47. End With
    
48. GoTo 100
    
49. lab:
    
50.     MsgBox "在总表或其它表中没有找到对应的字段！"
    
51. 100:
    
52. Set ggCell = Nothing
    
53. Set sh = Nothing
    
54. Application.ScreenUpdating = True
    
55. Application.DisplayAlerts = True
    
56. End Sub
    
57. Function getCell(str As String, sh As Worksheet)
    
58.     Set getCell = sh.Cells.Find(what:=str, lookat:=xlPart)
    
59. End Function
    

复制代码

mxg825

代码有几个地方可以再优化一下！

commanding05a

回复 mxg825 的帖子

谢谢你的无私帮助，我先试试

commanding05a

回复 mxg825 的帖子

mxg825兄，现在是这样，代码可行，但是运行速度较慢，当分表中工作簿数量达到60个左右的时候，有的时候程序就自动关闭了，还能再优化下速度么？