多个工作表合并到一个工作表

cam8

大家好！
我这里有个报表，是按每周一个工作表的形式制作的，一个工作簿有近50个工作表。
列的排列都是一样的，只是行数不同。
每个表都是从行13 开始计数，
现在需要把这些工作表整合到一个工作表中，不进行计算，单纯地将数据合并到一个工作表就可以。
因为所用的版本是英文版2007，在论坛上找过的vba程序都无法在我的excel中适用。

再次恳请各位能给出解决方案，将不胜感激！
谢谢

nkgsm

个人认为：VBA代码应该是适应所有excel版本的（不管是英文还是中文日文）

opiona

发附件上来，试试！

cam8

opiona 发表于 2015-7-20 16:10
发附件上来，试试！

附件好多，
不知道能否实现。
谢谢

cam8

烦请大家帮忙看看
谢谢

opiona

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona()
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. t = Timer   '//开始时间
    
13. 
    
14.    Set SH2 = Sheets("Sheet1")
    
15.    SH2.Range("A4:Z1048576").ClearContents
    
16.    FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, False)
    
17.    For I = 0 To UBound(FileArr)
    
18.    
    
19.       Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source =" & FileArr(I)    '//OFFICE2007
    
20.       Set WB = Workbooks.Open(FileArr(I))
    
21.       For Each SH In WB.Sheets
    
22.         If SH.Cells(5, 2) = "Voucher No" Then
    
23.             LASTROW = SH.Range("D65536").End(3).Row
    
24.             StrSQL = "SELECT F1,F2,F3,F4,F5,F6,F7,F8"
    
25.             StrSQL = StrSQL & ",NULL,'" & GetPathFromFileName(FileArr(I)) & "' AS 工作薄名"
    
26.             StrSQL = StrSQL & ",'" & SH.Name & "' AS 工作表名"
    
27.             StrSQL = StrSQL & " FROM [" & SH.Name & "$B11:I" & LASTROW & "]"
    
28.             
    
29.             SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
30.             IROW = SH2.Range("D65536").End(3).Row + 1
    
31.             If IROW <= 4 Then IROW = 4
    
32.             SH2.Range("A" & IROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
    
33.         End If
    
34.       Next SH
    
35.       WB.Close False
    
36.    Next I
    
37. Application.ScreenUpdating = True '//恢复屏幕刷新
    
38. Application.DisplayAlerts = True '//恢复系统提示
    
39. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
40. End Sub

复制代码

opiona

完整代码见附件： 新建文件夹.rar (1.86 MB, 下载次数: 341)

2015-7-20 17:28 上传

点击文件名下载附件

LMY123

多薄多表合并成一薄一表

lrh788

学习了！！！！！！！