Question

我有4个子文件夹，其中包含.xlsm格式的excel文件，在父文件夹中，我有一个主excel工作簿。我的程序将从子文件夹中所有excel工作簿的sheet1中找到的公共非连续单元格（A1，B5，C6）复制数据，并将其粘贴到主excel工作簿工作表（“模板”）中下面是摘录的代码，这些代码将循环遍历文件夹，并一次打开一个格式为xlsm的excel文件。然后将第一个工作簿中的单元格A1，B5，C6复制并关闭并将其粘贴到主工作簿模板表中的A2，B2和C2，然后将打开下一个excel文件副本A1，B5，C6。关闭工作簿并粘贴到主工作簿模板表中的A3，B3，C3。遍历子文件夹中的所有excel文件后，该过程将继续

'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

这是它应该如何正常工作：

Option Explicit
Sub Test()

    Dim wb As Workbook 'add a reference for the master workbook
    Dim CopyCellA As Range
    Dim CopyCellB As Range
    Dim CopyCellC As Range
    Set wb = ThisWorkbook 'if the master workbook is the one having the code


    '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
            With wbk.Sheets(1) '1 is the first sheet on the book, change this if not
                'The next 2 lines are useless because you are not using lastrow or lastcolumn anywhere
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'you also need to reference the rows.count
                LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 'same as above
                Set CopyCellA = .Range("A1")
                Set CopyCellB = .Range("B5")
                Set CopyCellC = .Range("C6")
            End With
            With wb.Sheets("MySheet") 'change MySheet for the sheet name where you are pasting
                erow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                .Cells(erow, 1) = CopyCellA 'no need to select
                .Cells(erow, 2) = CopyCellB
                .Cells(erow, 3) = CopyCellC
            End With

            'Close opened workbook without saving any changes
            wbk.Close SaveChanges:=False
            wb.Save
            Application.CutCopyMode = False

            myFile = Dir
        Loop
    Next myItem

    Application.ScreenUpdating = True

End Sub

从子文件夹excel文件复制非连续单元格（A1，B5，C6）中的数据，并将其粘贴到父文件夹中找到的主文件中

1 个答案: