VBA 复制一个EXCEL文件某列至另一个文件

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

  • 3
    点赞
  • 24
    收藏
    觉得还不错? 一键收藏
  • 1
    评论
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值