[已解决]提取当前文件夹下每个表格的G8：G25单元格

承诺与谁

自己研究别人的代码，改了一天都不得行。希望大神给帮忙改下(或者大神也可以重新写一个)。压缩包已经有了一个VBA，没有错误，但是也不能提取我想要的。

目的是：提取当前文件夹下的工作薄（包含每个工作表）的G7-G25单元格的数字，且为空的单元格，不提取。十分感谢了

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-11 12:48

1. Option Explicit
   
2. Sub test()
   
3. Dim mypath, myfile, wb, r, j, i
   
4. Range("A2:A" & Rows.Count).Clear
   
5. Application.ScreenUpdating = False
   
6. mypath = ThisWorkbook.Path & ""         '找到当前工作簿的路径
   
7. myfile = Dir(mypath & "*.xls*")          '遍历当前路径下的工作簿
   
8. Do While myfile <> ""                    '当找到的文件不为空时
   
9.     If myfile <> ThisWorkbook.Name Then   '当找到的文件不是本工作簿时
   
10.         Set wb = GetObject(mypath & myfile) '利用GetObject取得数据
    
11.         With wb.Sheets(1)                   '对wb的sheet1进行操作
    
12.             r = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Row + 1
    
13.             .Range("G8:G25").Copy ThisWorkbook.ActiveSheet.Cells(r, 1)
    
14.         End With
    
15.         wb.Close                   '别忘了关掉，要不然越开越多电脑就瘫痪了
    
16.     End If
    
17.     myfile = Dir                  '去找下一个工作簿
    
18. Loop
    
19. r = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Row
    
20. For j = r To 1 Step -1
    
21.     If Cells(j, 1) = "" Then
    
22.         Rows(j).Delete
    
23.     End If
    
24. Next
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码

跳转到最佳答案楼层

七彩屋

要的结果模拟一下

承诺与谁

七彩屋 发表于 2017-7-11 11:58
要的结果模拟一下

结果已经模拟了，还改变了下 。     麻烦大神了

chart888

1. Option Explicit
   
2. Sub test()
   
3. Dim mypath, myfile, wb, r, j, i
   
4. Range("A2:A" & Rows.Count).Clear
   
5. Application.ScreenUpdating = False
   
6. mypath = ThisWorkbook.Path & ""         '找到当前工作簿的路径
   
7. myfile = Dir(mypath & "*.xls*")          '遍历当前路径下的工作簿
   
8. Do While myfile <> ""                    '当找到的文件不为空时
   
9.     If myfile <> ThisWorkbook.Name Then   '当找到的文件不是本工作簿时
   
10.         Set wb = GetObject(mypath & myfile) '利用GetObject取得数据
    
11.         With wb.Sheets(1)                   '对wb的sheet1进行操作
    
12.             r = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Row + 1
    
13.             .Range("G8:G25").Copy ThisWorkbook.ActiveSheet.Cells(r, 1)
    
14.         End With
    
15.         wb.Close                   '别忘了关掉，要不然越开越多电脑就瘫痪了
    
16.     End If
    
17.     myfile = Dir                  '去找下一个工作簿
    
18. Loop
    
19. r = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Row
    
20. For j = r To 1 Step -1
    
21.     If Cells(j, 1) = "" Then
    
22.         Rows(j).Delete
    
23.     End If
    
24. Next
    
25. Application.ScreenUpdating = True
    
26. End Sub

复制代码

grf1973

换个不打开工作表的方法。。。。。

承诺与谁

grf1973 发表于 2017-7-11 14:46
换个不打开工作表的方法。。。。。

不行啊。大神

grf1973

可能是版本不对。。。。。。
把那句最长的前面改为  cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;....................再试试。