从子文件夹中复制非相邻单元格excel文件，并在父文件夹中找到的主Excel文件中逐行粘贴

Question

我有4个包含.xlsm格式的excel文件的子文件夹。 我需要从子文件夹中的所有excel文件中复制来自相同非连续单元格（A1，B5，C6）的数据。 我有一个父文件夹，其中存储了我的主工作簿。我希望每个excel文件（A1，B5，C6）中的数据以表格形式粘贴在主工作簿sheet1中。

'Loop through the collection

    For Each myItem In collSubFolders

'Loop through Excel workbooks in subfolder

      myFile = Dir(myFolder & myItem & "\*.xlsm*")



     Do While myFile <> “”

'Open workbook

     Set wbk = Workbooks.Open(Filename:=myFolder & myItem & " \ " & myFile)

'Copy data from the opened workbook

      lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

      lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

      ActiveSheet.Range("A1,B5,C6").Copy
'Close opened workbook without saving any changes

     wbk.Close SaveChanges:=False

           erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

      ActiveSheet.Cells(erow, 1).Select

      ActiveSheet.Paste

     ActiveWorkbook.Save

     Application.CutCopyMode = False

       myFile = Dir
     Loop

     Next myItem

       Application.ScreenUpdating = True


    End Sub

Answer 1

最大的问题是您正在尝试复制Excel不允许的一系列非连续单元格。 您还使用活动表，您应该直接处理工作簿和工作表。
您对所需内容或主文件的名称不是很精确，因此可以运行以将A1，B5，C6放在A1，A2，A3中的第1页上的主文件中，然后在列B用于下一个文件，通过单独的列打开您打开的每个文件。 您需要修改Dir命令以满足特定需求。

myfile = Dir(direct, "*.xlsm")  'sets myfile equal to the first file name
Do While myfile <> ""        'loops until there are no more files in the direstory
CLMS = Workbooks("Master_file.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column + 1
    Set wbk = Workbooks.Open(FileName:=fname)

    Workbooks(myfile).Sheets(1).Range("A1").Copy Workbooks("Master_file.xlsx").Sheets(1).Cells(1, CLMS)
    Workbooks(myfile).Sheets(1).Range("B5").Copy Workbooks("Master_file.xlsx").Sheets(1).Cells(2, CLMS)
    Workbooks(myfile).Sheets(1).Range("C6").Copy Workbooks("Master_file.xlsx").Sheets(1).Cells(3, CLMS)
           wbk.Close SaveChanges:=False`
Workbooks("Master_file.xlsx").save

     myfile = Dir            

Loop