VBA多指定单元格粘贴至下一行空白行问题求助

需求说明 #

• 从工作表「Weekly Resin Shear Trials」的E16:E20区域取值，拆分粘贴至目标工作表「84LMI NB1 Data」的E、G、I、K、M列
• 点击按钮时，先清空原复制来源的输入单元格
• 所有粘贴内容需放在同一空白行，首次从E7开始，后续每次自动定位到下一行空白行

当前问题 #

原代码每次粘贴不同数据时，会单独以对应列的最后一行计算偏移行号，若目标工作表各列已有内容的行数不一致，会导致同一操作的内容分散到不同行，呈现斜线分布。

修改后的代码 #

Sub LMI_NB1()
    Application.ScreenUpdating = False
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet
    Dim targetRow As Long ' 统一的目标行号
    
    ' 定义工作表对象
    Set copySheet = Worksheets("Weekly Resin Shear Trials")
    Set pasteSheet = Worksheets("84LMI NB1 Data")
    
    ' 确定目标工作表的下一个空白行（以E列为基准，确保首次从E7开始）
    targetRow = pasteSheet.Cells(Rows.Count, 5).End(xlUp).Row + 1
    If targetRow < 7 Then targetRow = 7
    
    ' --------------------------
    ' 1. 拆分粘贴Sample Data：E16:E20 → E、G、I、K、M列目标行
    ' --------------------------
    pasteSheet.Range("E" & targetRow & ",G" & targetRow & ",I" & targetRow & ",K" & targetRow & ",M" & targetRow).ClearContents
    pasteSheet.Cells(targetRow, 5).Value = copySheet.Cells(16, 5).Value
    pasteSheet.Cells(targetRow, 7).Value = copySheet.Cells(17, 5).Value
    pasteSheet.Cells(targetRow, 9).Value = copySheet.Cells(18, 5).Value
    pasteSheet.Cells(targetRow, 11).Value = copySheet.Cells(19, 5).Value
    pasteSheet.Cells(targetRow, 13).Value = copySheet.Cells(20, 5).Value
    
    ' --------------------------
    ' 2. 转置粘贴Shear Category：F16:F25 → O列目标行开始区域
    ' --------------------------
    pasteSheet.Range("O" & targetRow & ":O" & targetRow + 9).ClearContents
    copySheet.Range("F16:F25").Copy
    pasteSheet.Cells(targetRow, 15).PasteSpecial xlPasteValues, Transpose:=True
    
    ' --------------------------
    ' 3. 粘贴Date：I4 → B列目标行
    ' --------------------------
    pasteSheet.Cells(targetRow, 2).ClearContents
    copySheet.Range("I4").Copy
    pasteSheet.Cells(targetRow, 2).PasteSpecial xlPasteValuesAndNumberFormats
    
    ' --------------------------
    ' 4. 粘贴Operator：I5 → Y列目标行
    ' --------------------------
    pasteSheet.Cells(targetRow, 25).ClearContents
    copySheet.Range("I5").Copy
    pasteSheet.Cells(targetRow, 25).PasteSpecial xlPasteValues
    
    ' --------------------------
    ' 5. 转置粘贴Log No. & Expiry：E13:E14 → C、D列目标行
    ' --------------------------
    pasteSheet.Range("C" & targetRow & ":D" & targetRow).ClearContents
    copySheet.Range("E13:E14").Copy
    pasteSheet.Cells(targetRow, 3).PasteSpecial xlPasteValues, Transpose:=True
    
    ' --------------------------
    ' 清空原输入单元格（复制来源区域）
    ' --------------------------
    copySheet.Range("E13:E14,E16:E20,F16:F25,I4:I5").ClearContents
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

关键修改点 #

• 新增targetRow变量，提前计算统一的目标空白行号，所有粘贴操作基于该行号执行，彻底避免内容分散
• 以E列为基准确定目标行，同时添加判断确保首次运行从E7开始
• 对E16:E20的拆分粘贴改用单元格直接赋值，比复制转置更精准，减少格式干扰
• 新增目标单元格和原输入单元格的清空逻辑，满足需求

内容的提问来源于stack exchange，提问作者James McLaughlin