如何编写VBA代码从选中区域提取指定列并粘贴到另一工作表末尾

你之前的代码仅通过Resize(,2)截取了选中行的前2列，所以只能复制A、B列，要提取非连续的A/B/E/F/G列，通过Union方法拼接目标列即可：

Sub 复制选中行到汇总表()
    Dim 选中范围 As Range, 待复制范围 As Range, 目标起始单元格 As Range
    
    ' 统一处理为整行范围，避免用户仅选中单个单元格时报错
    Set 选中范围 = Selection.EntireRow
    
    ' 拼接需要复制的5列
    Set 待复制范围 = Union(选中范围.Columns("A"), 选中范围.Columns("B"), _
                        选中范围.Columns("E"), 选中范围.Columns("F"), 选中范围.Columns("G"))
    
    ' 定位汇总表的首个空行
    Set 目标起始单元格 = Sheets("Summary").Range("A" & Sheets("Summary").Rows.Count).End(xlUp).Offset(1)
    
    ' 粘贴逻辑和你原有逻辑保持一致，同时保留格式和值
    待复制范围.Copy
    目标起始单元格.PasteSpecial xlPasteAll
    目标起始单元格.PasteSpecial xlPasteValues
    
    ' 清除剪贴板选中状态
    Application.CutCopyMode = False
End Sub

如果不需要保留单元格格式、批注等内容，仅需要复制数值，可以用直接赋值的方式，效率更高且不会占用剪贴板：

Sub 复制选中行到汇总表_仅数值()
    Dim 选中范围 As Range, 目标起始单元格 As Range
    Dim 选中行数 As Long
    
    Set 选中范围 = Selection.EntireRow
    选中行数 = 选中范围.Rows.Count
    
    ' 定位目标区域起始位置，和选中行数保持一致
    Set 目标起始单元格 = Sheets("Summary").Range("A" & Sheets("Summary").Rows.Count).End(xlUp).Offset(1).Resize(选中行数)
    
    ' 逐列赋值
    目标起始单元格.Value = 选中范围.Columns("A").Value
    目标起始单元格.Offset(0, 1).Value = 选中范围.Columns("B").Value
    目标起始单元格.Offset(0, 2).Value = 选中范围.Columns("E").Value
    目标起始单元格.Offset(0, 3).Value = 选中范围.Columns("F").Value
    目标起始单元格.Offset(0, 4).Value = 选中范围.Columns("G").Value
End Sub

• 若你的汇总表名称不是Summary，修改代码中对应工作表名称即可
• 如需绑定按钮，在Excel开发工具选项卡中插入表单控件按钮，选择对应宏绑定即可

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