Excel vb代码中提取sheet1中指定列内容到sheet2中指定位置代码

共计 1618 个字符，预计需要花费 5 分钟才能阅读完成。

经常碰到我们需要提取 excel 表 1 中的指定内容到 excel 表 2 中，

可以使用一下代码提取。

Sub ExtractColumns()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceRange1 As Range, sourceRange2 As Range, sourceRange3 As Range
Dim targetCell1 As Range, targetCell2 As Range, targetCell3 As Range

' 设置源和目标工作表
On Error Resume Next
Set sourceSheet = ThisWorkbook.Sheets("Sheet1") ' 源表格的名称
Set targetSheet = ThisWorkbook.Sheets("Sheet2") ' 目标表格的名称
On Error GoTo ErrorHandler

' 检查源和目标工作表是否存在
If sourceSheet Is Nothing Then
MsgBox "源工作表'Sheet1'不存在，请检查工作表名称！", vbExclamation
Exit Sub
End If
If targetSheet Is Nothing Then
MsgBox "目标工作表'Sheet2'不存在，请检查工作表名称！", vbExclamation
Exit Sub
End If

' 定义源范围
On Error Resume Next
Set sourceRange1 = sourceSheet.Range("B3:B25") ' 第一列数据
Set sourceRange2 = sourceSheet.Range("D3:D25") ' 第二列数据
Set sourceRange3 = sourceSheet.Range("H3:H25") ' 第三列数据
On Error GoTo ErrorHandler

' 检查源范围是否有效
If sourceRange1 Is Nothing Or sourceRange2 Is Nothing Or sourceRange3 Is Nothing Then
MsgBox "源范围无效，请检查范围是否正确！", vbExclamation
Exit Sub
End If

' 定义目标位置
Set targetCell1 = targetSheet.Cells(4, 2) ' B4 (列 B 的第 4 行)
Set targetCell2 = targetSheet.Cells(4, 3) ' C4 (列 C 的第 4 行)
Set targetCell3 = targetSheet.Cells(4, 4) ' D4 (列 D 的第 4 行)

' 检查目标位置是否有效
If targetCell1 Is Nothing Or targetCell2 Is Nothing Or targetCell3 Is Nothing Then
MsgBox "目标位置无效，请检查目标范围是否正确！", vbExclamation
Exit Sub
End If

' 复制范围到目标位置
sourceRange1.Copy targetCell1
sourceRange2.Copy targetCell2
sourceRange3.Copy targetCell3

MsgBox "数据已提取完成！", vbInformation
Exit Sub

ErrorHandler:
MsgBox "发生错误：" & Err.Description, vbCritical
End Sub

如何使用代码

1. 打开 Excel 工作簿。
2. 按 Alt + F11 打开 VBA 编辑器。
3. 在 VBA 编辑器中，点击菜单栏的 插入 -> 模块，新建一个模块。
4. 将上述代码粘贴到模块窗口中。
5. 修改代码中的工作表名称和范围，以匹配你的实际需求。
6. 关闭 VBA 编辑器，回到 Excel。
7. 按 Alt + F8 打开宏列表，选择 ExtractColumns，然后点击 运行。

注意事项

• 如果目标工作表中已经有数据，代码会覆盖目标位置的数据。如果需要避免覆盖，可以在代码中添加检查逻辑。
• 确保 Excel 工作簿启用了宏功能（文件 -> 选项 -> 信任中心 -> 宏设置）。