[已解决]如何用VBA将2个或多个工作表中的内容复制到一个工作表中，且中间空一行，如图。

zl1975

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-29 17:58

1. Sub 多表合并()
   
2.     Dim lLastrow As Long
   
3.     Dim mergesheet$
   
4.     Dim sht
   
5.     mergesheet = "Sheet3"
   
6.     Sheet8.UsedRange.Clear
   
7.     For Each sht In Worksheets
   
8.         If sht.Name <> mergesheet Then
   
9.             lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
10.             If lLastrow <> 1 Then lLastrow = lLastrow + 2
    
11.             sht.Range("a1").CurrentRegion.Copy Range("a" & lLastrow)
    
12.         End If
    
13.     Next
    
14. End Sub

复制代码

代码只针对这个工作表，如果你套用别的，得改才行，原理都是一样的。

跳转到最佳答案楼层

hwc2ycy

复制粘贴。
不停的COPY（带目标位置就行了）

zl1975

hwc2ycy 发表于 2013-3-29 13:06
复制粘贴。
不停的COPY（带目标位置就行了）

一百多个工作表，这样复制慢呀，能否用VBA做到快速合并？谢谢你的帮助！

hwc2ycy

你传附件上来。

zl1975

hwc2ycy 发表于 2013-3-29 13:13
你传附件上来。

合并工作表.zip (9.04 KB, 下载次数: 8)

2013-3-29 16:52 上传

点击文件名下载附件

hwc2ycy

1. Sub 多表合并()
   
2.     Dim lLastrow As Long
   
3.     Dim mergesheet$
   
4.     Dim sht
   
5.     mergesheet = "Sheet3"
   
6.     Sheet8.UsedRange.Clear
   
7.     For Each sht In Worksheets
   
8.         If sht.Name <> mergesheet Then
   
9.             lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
10.             If lLastrow <> 1 Then lLastrow = lLastrow + 2
    
11.             sht.Range("a1").CurrentRegion.Copy Range("a" & lLastrow)
    
12.         End If
    
13.     Next
    
14. End Sub

复制代码

代码只针对这个工作表，如果你套用别的，得改才行，原理都是一样的。