请老师帮忙只提取文件夹中工作簿的合计栏数据，谢谢

qdchyq

请老师帮忙用vba提取文件夹中工作簿的合计栏数据，谢谢 新建文件夹.rar (10.21 KB, 下载次数: 7)

2015-6-25 15:58 上传

点击文件名下载附件

qdchyq

哪位老师帮帮忙，谢谢

看见星光

1. Sub tt()
   
2. Dim ws As Workbook, sht As Worksheet, path, str, i&, d
   
3. Application.ScreenUpdating = False
   
4. Set sht = ActiveSheet
   
5. path = ThisWorkbook.path & ""
   
6. d = Dir(path & "*.xls")
   
7.     Do While d <> ""
   
8.         If d <> ThisWorkbook.Name Then
   
9.             Set ws = Workbooks.Open(path & d)
   
10.                 i = sht.Cells(Rows.Count, 1).End(3).Row + 1
    
11.                 With ws.Sheets(1)
    
12.                     sht.Cells(i, 1) = Replace(.[a1], "填报单位：", "")
    
13.                     .Cells(Rows.Count, 1).End(3).Offset(0, 1).Resize(1, 8).Copy
    
14.                     sht.Cells(i, 3).PasteSpecial (xlPasteValues)
    
15.                 End With
    
16.             ws.Close False
    
17.         End If
    
18.         d = Dir
    
19.     Loop
    
20. Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

看见星光

新建文件夹.rar (21.88 KB, 下载次数: 5)

2015-6-25 17:24 上传

点击文件名下载附件

jjmysjg

看见星光 发表于 2015-6-25 17:24

太棒了！
这个代码是合并个表未行数据。
能否写个语句，即查询到A列有“合计”字符的，将其整行复制到汇总表

看见星光

jjmysjg 发表于 2015-6-25 18:00
太棒了！
这个代码是合并个表未行数据。
能否写个语句，即查询到A列有“合计”字符的，将其整行复制到 ...

1. Sub tt()
   
2. Dim ws As Workbook, sht As Worksheet, path, str, i&, d
   
3. Application.ScreenUpdating = False
   
4. [a3:i5000].ClearContents
   
5. Set sht = ActiveSheet
   
6. path = ThisWorkbook.path & ""
   
7. d = Dir(path & "*.xls")
   
8.     Do While d <> ""
   
9.         If d <> ThisWorkbook.Name Then
   
10.             Set ws = Workbooks.Open(path & d)
    
11.                 i = sht.Cells(Rows.Count, 1).End(3).Row + 1
    
12.                 With ws.Sheets(1)
    
13.                     sht.Cells(i, 1) = Replace(.[a1], "填报单位：", "")
    
14.                     .Columns(1).Find("合计").Offset(0, 1).Resize(1, 8).Copy
    
15.                     sht.Cells(i, 3).PasteSpecial (xlPasteValues)
    
16.                 End With
    
17.             ws.Close False
    
18.         End If
    
19.         d = Dir
    
20.     Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

看见星光

新建文件夹.zip (22.6 KB, 下载次数: 11)

2015-6-25 20:12 上传

点击文件名下载附件

附件参考

jjmysjg

看见星光 发表于 2015-6-25 20:13
附件参考

谢谢看见星光大师！