excel 将数据从位于同一文件夹中的多个工作簿复制并粘贴到预先存在的工作簿的多个工作表中

z0qdvdin  于 2023-01-18  发布在  其他
关注(0)|答案(2)|浏览(142)

请,我想知道我是否可以得到一些帮助的VBA代码,可以执行以下操作:
将数据从位于同一文件夹中的多个工作簿复制并粘贴到预先存在的工作簿的多个工作表中。
我的C盘中有一个文件夹,其中包含10个工作簿。每个工作簿文件命名为:

  • 工作簿_A_01
  • 工作簿_A_02
  • 工作簿_A_03
  • 工作簿_A_04
  • 工作簿_A_05
  • 工作簿_A_06
  • 工作簿_A_07
  • 工作簿_A_08
  • 工作簿_A_09
  • 工作簿_A_10

文件夹中的所有工作簿都相似(一个工作表、固定数据范围、相同的标题...)。我希望使用已有的工作簿,它有11个空工作表,命名为:

  • 概述
  • 01
  • 02
  • 03
  • ...
  • 10

我希望从每个工作簿_A_XX复制相同范围的数据(A200:E600),并将其粘贴到预先存在的工作簿中,如下所示:
从Workbook_A_01复制范围(A200:E600)并将其粘贴到预先存在的工作簿中,粘贴到工作表"01"中,从单元格C6开始
从Workbook_A_02复制范围(A200:E600),并将其粘贴到预先存在的工作簿中,然后粘贴到工作表"02"中,从单元格C6开始
从Workbook_A_03复制区域(A200:E600),并将其粘贴到预先存在的工作簿中的工作表"03"中,从单元格C6开始...
从Workbook_A_10复制区域(A200:E600),并将其粘贴到现有工作簿中的工作表"10"中,从单元格C6开始
非常感谢。
我是VBA新手。我唯一能做的就是把所有的工作簿合并成一个。它很有效,但不幸的是,购买运行代码,我不能从每个工作簿中选择一个特定的范围复制粘贴到目标位置。

yiytaume

yiytaume1#

请,始终张贴您的代码,即使它不工作:

Sub alwayspostyourcode()

Dim wbSource As Workbook
Dim wbtarget As Workbook

Set wbtarget = ThisWorkbook 'assuming the workbook with the macro is the destination

For i = 1 To 10

    strI = Right("0" & Trim(Str(i)), 2)
    Set wbSource = Workbooks.Open("Workbook_A_" & strI & ".xlsx")
    wbSource.Sheets(1).Range("A200:E600").Copy Destination:=wbtarget.Sheets(strI).Range("C6")
    wbSource.Close
Next i

End Sub
kqlmhetl

kqlmhetl2#

从关闭的工作簿导入

Option Explicit

Sub ImportData()

    Const SRC_FOLDER_PATH As String = "C:\Test\"
    Const SRC_WORKSHEET_ID As Variant = 1
    Const SRC_RANGE As String = "A200:E600"
    Const DST_FIRST_CELL As String = "A6"
    
    Dim swbNames(): swbNames = VBA.Array("Workbook_A_01.xlsx", _
        "Workbook_A_02.xlsx", "Workbook_A_03.xlsx", "Workbook_A_04.xlsx", _
        "Workbook_A_05.xlsx", "Workbook_A_06.xlsx", "Workbook_A_07.xlsx", _
        "Workbook_A_08.xlsx", "Workbook_A_09.xlsx", "Workbook_A_10.xlsx")
    Dim dwsNames(): dwsNames = VBA.Array("01", "02", "03", "04", _
        "05", "06", "07", "08", "09", "10")
        
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range
    Dim dws As Worksheet, dfCell As Range
    Dim n As Long
    
    For n = 0 To UBound(swbNames)
        
        Set swb = Workbooks.Open(SRC_FOLDER_PATH & swbNames(n))
        Set sws = swb.Worksheets(SRC_WORKSHEET_ID)
        Set srg = sws.Range(SRC_RANGE)
        
        Set dws = dwb.Worksheets(dwsNames(n))
        Set dfCell = dws.Range(DST_FIRST_CELL)
        
        srg.Copy dfCell
        
        swb.Close SaveChanges:=False
    
    Next n
    
    Application.ScreenUpdating = True
    
    MsgBox "Data imported.", vbInformation

End Sub

相关问题