[已解决]求一个合并工作表的vba代码

yewei113

要求，把选中的工作表内容合并到在一起并建立一个新的工作表。

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2014-1-1 19:49

刚才没有注意A列有空的情况，现更正代码如下：
合并工作表.zip (21.41 KB, 下载次数: 16)

2014-1-1 19:49 上传

点击文件名下载附件

1. Sub 合并()
   
2. Dim sh As Worksheet, i&, j&, r&
   
3.    Set sh = Sheets(Sheets.Count)
   
4.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Delete
   
5.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Insert
   
6. For i = 1 To Sheets.Count - 1
   
7.     If sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
   
8.        r = 1
   
9.     Else
   
10.        r = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    
11.     End If
    
12.    
    
13.     Sheets(i).UsedRange.Copy sh.Range("a" & r)
    
14. Next i
    
15. End Sub
    

复制代码

跳转到最佳答案楼层

yyyydddd8888

看看行不行：
合并工作表.zip (21.41 KB, 下载次数: 4)

2014-1-1 19:46 上传

点击文件名下载附件

1. Option Explicit
   
2. Sub 合并()
   
3. Dim sh As Worksheet, i&, j&, r&
   
4.    Set sh = Sheets(Sheets.Count)
   
5.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Delete
   
6.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Insert
   
7. For i = 1 To Sheets.Count - 1
   
8.     If sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
   
9.        r = 1
   
10.     Else
    
11.        r = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    
12.     End If
    
13.    
    
14.     Sheets(i).UsedRange.Copy sh.Range("a" & r)
    
15. Next i
    
16. End Sub
    

复制代码

yyyydddd8888

刚才没有注意A列有空的情况，现更正代码如下：
合并工作表.zip (21.41 KB, 下载次数: 16)

2014-1-1 19:49 上传

点击文件名下载附件

1. Sub 合并()
   
2. Dim sh As Worksheet, i&, j&, r&
   
3.    Set sh = Sheets(Sheets.Count)
   
4.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Delete
   
5.    sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Insert
   
6. For i = 1 To Sheets.Count - 1
   
7.     If sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
   
8.        r = 1
   
9.     Else
   
10.        r = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    
11.     End If
    
12.    
    
13.     Sheets(i).UsedRange.Copy sh.Range("a" & r)
    
14. Next i
    
15. End Sub
    

复制代码

yyyydddd8888

因为要照顾按钮，所以增加了这两句代码，如果把按钮设置在第一个工作表，可以去掉这两句：
sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Delete
sh.Range(Cells(1, 1), Cells(1, 10)).EntireColumn.Insert


按钮在工作表1 合并工作表.zip (21.34 KB, 下载次数: 18)

2014-1-1 20:21 上传

点击文件名下载附件

1. Sub 合并()
   
2. Dim sh As Worksheet, i&, r&
   
3.    Set sh = Sheets(Sheets.Count)
   
4.    sh.Cells.Delete
   
5. For i = 1 To Sheets.Count - 1
   
6.     If sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
   
7.        r = 1
   
8.     Else
   
9.        r = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
   
10.     End If
    
11.    
    
12.     Sheets(i).UsedRange.Copy sh.Range("a" & r)
    
13. Next i
    
14. Sheets(Sheets.Count).Select
    
15. End Sub
    

复制代码

yewei113

谢谢各位