[已解决]关于合并同一目录下多个excel文件的问题、inputBox（）函数问题

2266116

cxsj717 发表于 2011-10-21 22:02
2266116
能说的再明白点吗

Usedrange是已使用的单元格包括表头,改为如:Range("a3:P50")它就复制a3到p50区域,实际情况你自己按你的表格改.

zjdh

1. Sub 合并当前目录下所有工作簿的全部工作表()
   
2.     Dim MyPath, MyName, AWbName
   
3.     Dim Wb As Workbook, WbN As String
   
4.     Dim G As Long
   
5.     Dim Num As Long
   
6.     Dim BOX As String
   
7.     Dim strFile As String
   
8.     Application.ScreenUpdating = False
   
9.     strFile = InputBox("请关闭所有EXCLE文件，复制地址栏粘贴到文本框内，提取文件路径！", "打开路径下工作簿文件") & ""
   
10.     If strFile = "" Then Exit Sub
    
11.     MyPath = strFile
    
12.     MyName = Dir(MyPath & "" & "*.xls")
    
13.     AWbName = ActiveWorkbook.Name
    
14.     Num = 0
    
15.     Do While MyName <> ""
    
16.         If MyName <> AWbName Then
    
17.             Set Wb = Workbooks.Open(MyPath & "" & MyName)
    
18.             Num = Num + 1
    
19.             With Workbooks(1).ActiveSheet
    
20.                 If Num = 1 Then
    
21.                     .Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
    
22.                 End If
    
23.                 For G = 1 To Sheets.Count
    
24.                     Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
    
25.                 Next
    
26.                 WbN = WbN & Chr(13) & Wb.Name
    
27.                 Wb.Close False
    
28.             End With
    
29.         End If
    
30.         MyName = Dir
    
31.     Loop
    
32.     Range("A1").Select
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
    
35. End Sub

复制代码

cxsj717

还是不行，zjdh ，不过这样已经很好了

2266116

回复 cxsj717 的帖子

wb.Sheets(G).UsedRange.Offset(你表头的行数,0).Copy .Cell(.Range("A65536").End(3).Row+1,1)