如何将Active工作表两个不连续区域复制到DATA表首空行并连续合并?
解决VBA中合并复制不连续区域并横向连续粘贴的问题
我来帮你搞定这个问题!你当前代码的核心问题是两次粘贴都指向了目标表的同一行起始位置,加上复制的是多行区域,导致第二个区域被挤到了第一个的下方。我们需要明确两个区域的横向目标位置,让它们在同一行范围内横向衔接。
方法一:直观的Copy/Paste实现
这种写法逻辑清晰,容易理解,适合新手调试:
Sub CopyAndMergeRegions() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim lastRowTarget As Long Dim targetStartCol As Long ' 定义源工作表(当前活动表)和目标工作表 Set wsSource = ActiveSheet Set wsTarget = ThisWorkbook.Sheets("DATA") ' 找到目标表的首空行(A列最后一行的下一行) lastRowTarget = wsTarget.Range("A" & wsTarget.Rows.Count).End(xlUp).Row + 1 ' 复制第一个区域(A5:T1346)到目标表首空行的A列起始位置 wsSource.Range("A5:T1346").Copy wsTarget.Range("A" & lastRowTarget) ' 计算第二个区域的目标起始列:A-T共20列,所以从第21列(U列)开始 targetStartCol = wsSource.Range("A5:T1346").Columns.Count + 1 ' 复制第二个区域(AC5:AH1346)到目标表首空行的U列起始位置 wsSource.Range("AC5:AH1346").Copy wsTarget.Cells(lastRowTarget, targetStartCol) End Sub
方法二:高效的直接赋值(避免程序冻结)
如果你的数据量较大,Copy/Paste会占用剪贴板且速度较慢,甚至导致程序冻结。直接用Value赋值跳过剪贴板,是更优的选择:
Sub CopyAndMergeRegionsFast() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim lastRowTarget As Long Dim sourceRange1 As Range Dim sourceRange2 As Range Set wsSource = ActiveSheet Set wsTarget = ThisWorkbook.Sheets("DATA") lastRowTarget = wsTarget.Range("A" & wsTarget.Rows.Count).End(xlUp).Row + 1 ' 定义两个需要复制的源区域 Set sourceRange1 = wsSource.Range("A5:T1346") Set sourceRange2 = wsSource.Range("AC5:AH1346") ' 直接把第一个区域的值赋值到目标位置 wsTarget.Range("A" & lastRowTarget).Resize(sourceRange1.Rows.Count, sourceRange1.Columns.Count).Value = sourceRange1.Value ' 把第二个区域的值赋值到U列开始的位置,自动匹配行数和列数 wsTarget.Cells(lastRowTarget, sourceRange1.Columns.Count + 1).Resize(sourceRange2.Rows.Count, sourceRange2.Columns.Count).Value = sourceRange2.Value End Sub
关键优化点说明
- 用对象变量(
wsSource、wsTarget)代替重复调用ActiveSheet和Sheets("DATA"),让代码更清晰且不易出错。 - 通过第一个区域的列数计算第二个区域的起始列,就算以后调整第一个区域的列范围,代码也能自动适配,不用手动修改列号。
- 直接赋值的方式完全跳过剪贴板,数据传输效率提升数倍,彻底解决你之前遇到的程序冻结问题。
内容的提问来源于stack exchange,提问作者jps17183
相关产品推荐
相关产品推荐

