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放在主文件中的工作表1的A1，A2，A3中，然后将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

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

1 个答案: