VBA怎么把工作簿A中的第N列,复制到工作簿B中的第N列。
https://ask.csdn.net/questions/7846408/53999954?spm=1001.2014.3001.5501
之前有位同学提到上述需求,但系统已关闭回答修改权限,
故重新发以下更新代码,以实现在目标工作表对应列末追加方式,仅供参考
Sub copy_AToB()
'假设两个独立表格文件,源表复制列内容后,在目标列后面粘贴
Dim Wbook1 As Workbook, Wbook2 As Workbook
Dim path_A, path_B '测试路径
Dim ABookName, BBookName '测试文件名称
Dim aCol As Integer, bCol As Integer '列号
Dim i As Integer '行数
Dim j As Integer '列数
Dim k As Integer '搜索某列最后一个非空单元格行号
Application.ScreenUpdating = False '暂停刷新
'Application.DisplayAlerts = False '使不弹出询问 是否替换目标单元格内容
path_A = "D:\"
ABookName = "checkA.xlsx" 'A表格文件名称
path_B = "E:\"
BBookName = "checkB.xlsx" 'B表格文件名称
aCol = 3 'A表格的源列号 按需求灵活调整
bCol = 6 'B表格的目标列号
If ABookName = BBookName Then
MsgBox "两个文件名称不能相同", vbInformation, "提示"
Exit Sub
End If
ABookName = path_A & ABookName '加路径组合
BBookName = path_B & BBookName
If Dir(ABookName, 16) = vbNullString Then '检查文件是否存在
MsgBox "未找到 " & ABookName, vbInformation, "提示"
Exit Sub
End If
If Dir(BBookName, 16) = vbNullString Then
MsgBox "未找到 " & BBookName, vbInformation, "提示"
Exit Sub
End If
'文件存在的条件为 Not Dir(ABookName, 16) = vbNullString
Set Wbook1 = Workbooks.Open(ABookName) '打开A文件
Wbook1.Sheets(1).Activate
'取行数
i = Wbook1.Sheets(1).UsedRange.Cells(Sheets(1).UsedRange.Rows.Count, 1).Row
'取列数
j = Wbook1.Sheets(1).UsedRange.Cells(1, Sheets(1).UsedRange.Columns.Count).Column
If i = 1 And IsEmpty(Cells(1, aCol).Value) Then
MsgBox BBookName & " 第1行第" & aCol & "列没有数据", vbExclamation, "提示"
Wbook1.Close '关闭A文件
Exit Sub
End If
'ActiveSheet.Columns(aCol).Copy '整列复制,这方式粘贴至目标表可整列覆盖,较少用
k = ActiveSheet.Cells(Rows.Count, aCol).End(xlUp).Row '源表对应列最后一个非空单格行号
'Cells(Rows.Count, 1) 表示找第1列最后一个非空单格
'End(xlUp) 表示向上搜索,可写为End(3)
'复制源表对应列第1行至最后行的内容
'若第一行为列名称不复制,则调整行号为2开始,即下方“Cells(1, aCol)”改为“Cells(2, aCol)”
With Worksheets(1)
.Range(.Cells(1, aCol), .Cells(k, aCol)).Copy
End With
Set Wbook2 = Workbooks.Open(BBookName) '打开B文件
Wbook2.Sheets(1).Activate
'ActiveSheet.Columns(bCol).PasteSpecial '拷贝至目标列 整列覆盖方式较少用
k = ActiveSheet.Cells(Rows.Count, bCol).End(xlUp).Row '目标工作表对应列最后一个非空单格行号
If (k = 1 And Not IsEmpty(Cells(1, bCol).Value)) Or k > 1 Then
'若返回非空单元格行号为“1”,且对应列第1个单元格不为空
'或者非空单元格行号大于“1”
k = k + 1 '调整将要粘贴的起始空行号+1
End If
ActiveSheet.Cells(k, bCol).PasteSpecial '对应目标列非空单元格的下一行单元格位置粘贴
'清空剪贴板,避免关闭文件命令时弹出提示类似“在剪贴板上有大量信息。是否保留其内容,以便此后粘贴到其他程序中?”
Application.CutCopyMode = False '清空
Wbook1.Close '关闭A文件
Wbook2.Save '保存B文件
'Wbook2.SaveAs Filename:="E:\checkB_New.xlsx" '此句测试另存为新文件
Wbook2.Close '关闭B文件
MsgBox "将 " & ABookName & " (源表共" & i & "行" & j & "列)的第" & aCol & "列拷贝至 " & BBookName & " 第" & bCol & "列完成", vbInformation, "提示"
Application.ScreenUpdating = True
End Sub