按指定要求,将带格式大量数据,从一个Excel工作簿粘贴到另一个Excel工作簿(VBA宏)

        如题,代码注释很详细,稍作修改就可以用,运行前需要打开你的两个工作簿。

        详细解释版本:

                有两个工作簿,每个工作簿都有几百张表,表的数量是一样的,

                我需要从一个工作簿中将指定位置的数据粘贴到另一个工作簿的指定位置

                要保持格式不变

        我首先尝试了Python,但是失败了,我搞定的地方在于:

                (1)保存问题,一次只能保存一张表而不是一个工作簿。

                (2)格式问题,我需要读出原表格式然后写入新表。

注意:当数据量过大时,请不要关闭屏幕刷新,excel可能会出现”警告:剪贴板错误“,该错误会导致数据中的某几项粘贴出错。

Sub 宏1()
'
' 宏1 宏
'

'
    Dim wb1 As Workbook  '定义一个工作簿变量
    Dim wb2 As Workbook  '定义一个工作部变量
    Dim ws As Worksheet  '定义一个工作表变量
    Dim i As Integer     '定义一个整数型变量
 
    Set wb1 = Workbooks("原始.xlsx")   '设置变量值
    Set wb2 = Workbooks("粘贴.xlsx")
      
    For i = 1 To wb1.Worksheets.Count   
'遍历我的所有工作表,wb1.Worksheets.Count用于获取原始工作表的数量
   
'打开原始工作簿
        Windows("原始.xlsx").Activate
'选择第I个工作表
        Sheets(wb1.Worksheets.Item(i).Name).Select
'选择需要复制的单元格
        Range("B2:C2").Select
'复制它们
        Selection.Copy
        
'打开粘贴工作簿
        Windows("粘贴.xlsx").Activate
'选择第I个工作表
        Sheets(wb1.Worksheets.Item(i).Name).Select
'选择需要粘贴的单元格
        Range("B2:C2").Select
'粘贴
        ActiveSheet.Paste
        
'以下为重复上述步骤,因为我有不同的需要粘贴的数据
        Windows("原始.xlsx").Activate
        Sheets(wb1.Worksheets.Item(i).Name).Select
        Range("B4:C4").Select
        Selection.Copy
        
        Windows("粘贴.xlsx").Activate
        Sheets(wb1.Worksheets.Item(i).Name).Select
        Range("B4:C4").Select
        ActiveSheet.Paste
        
        Windows("原始.xlsx").Activate
        Sheets(wb1.Worksheets.Item(i).Name).Select
        Range("E4:F4").Select
        Selection.Copy
        
        Windows("粘贴.xlsx").Activate
        Sheets(wb1.Worksheets.Item(i).Name).Select
        Range("E4:F4").Select
        ActiveSheet.Paste
        
    Next   '下一个,相当于i+1
End Sub

  • 1
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
以下是一个将WORD所有表格数据复制一个Excel SheetVBA代码示例: ``` Sub CopyWordTableToExcel() Dim wdDoc As Object Dim wdTable As Object Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim i As Integer Dim j As Integer Dim n As Integer '打开WORD文档 Set wdDoc = GetObject("C:\your\file\path.docx") '创建一个新的Excel应用程序 Set xlApp = CreateObject("Excel.Application") '打开一个新的Excel工作簿 Set xlWb = xlApp.Workbooks.Add '选择第一个工作表 Set xlWs = xlWb.Worksheets(1) '遍历WORD文档的所有表格 For i = 1 To wdDoc.Tables.Count Set wdTable = wdDoc.Tables(i) '将表格数据复制Excel工作 For j = 1 To wdTable.Rows.Count For n = 1 To wdTable.Columns.Count xlWs.Cells(j, n) = wdTable.Cell(j, n).Range.Text Next n Next j '在Excel工作插入一个空行,以便区分不同的表格数据 xlWs.Rows(j).Insert Next i '保存Excel工作簿 xlWb.SaveAs "C:\your\file\path.xlsx" '关闭Excel应用程序 xlApp.Quit '释放资源 Set wdDoc = Nothing Set wdTable = Nothing Set xlWs = Nothing Set xlWb = Nothing Set xlApp = Nothing End Sub ``` 请将代码的文件路径替换为您的WORD文档路径和Excel文件路径,并在VBA编辑器运行该代码。该代码将遍历WORD文档的所有表格,并将表格数据复制一个新的Excel工作簿的第一个工作。每个表格数据之间将插入一个空行以便区分。最后,将Excel工作簿保存到指定路径,并关闭Excel应用程序。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

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

抵扣说明:

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

余额充值