[已解决]VBA合并当前目录下，工作薄时，不固定列数

yjwdjfqb

VBA合并当前目录下，工作薄时，不固定列数



请老师们帮帮忙，谢谢大家了！
VBA合并工作薄.rar (31.78 KB, 下载次数: 16)

2014-10-31 16:13 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-31 17:51

1. Sub Macro1()
   
2. Dim mypath$$, wj$$, wb As Workbook, n&, s&
   
3. Application.ScreenUpdating = False
   
4. ActiveSheet.UsedRange.Clear
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls*")
   
7. Do While wj <> ""
   
8.     If wj <> ThisWorkbook.Name Then
   
9.         n = n + 1
   
10.         Set wb = GetObject(mypath & wj)
    
11.         If n = 1 Then
    
12.             wb.Sheets(1).UsedRange.Copy [a1]
    
13.         Else
    
14.             s = Range("a65536").End(xlUp).Row + 1
    
15.             wb.Sheets(1).UsedRange.Offset(1, 0).Copy Cells(s, 1)
    
16.         End If
    
17.         wb.Close 0
    
18.     End If
    
19.     wj = Dir
    
20. Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim mypath$$, wj$$, wb As Workbook, n&, s&
   
3. Application.ScreenUpdating = False
   
4. ActiveSheet.UsedRange.Clear
   
5. mypath = ThisWorkbook.Path & ""
   
6. wj = Dir(mypath & "*.xls*")
   
7. Do While wj <> ""
   
8.     If wj <> ThisWorkbook.Name Then
   
9.         n = n + 1
   
10.         Set wb = GetObject(mypath & wj)
    
11.         If n = 1 Then
    
12.             wb.Sheets(1).UsedRange.Copy [a1]
    
13.         Else
    
14.             s = Range("a65536").End(xlUp).Row + 1
    
15.             wb.Sheets(1).UsedRange.Offset(1, 0).Copy Cells(s, 1)
    
16.         End If
    
17.         wb.Close 0
    
18.     End If
    
19.     wj = Dir
    
20. Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码