none
Macro - copying a worksheet from an active workbook to multiples workbooks in the same folder RRS feed

  • Question

  • I am developing a "simple" macro to copy two worksheet from a standard file and add into multiples workbooks located in the same file . The standard file is located in a different folder .I am facing a problem with the below function to refer to all files :

     Sheets("Change History ").Copy Before:=Workbooks(xFileName <> "").Sheets(1)

    Below is the macro :

    Sub LoopThroughFiles()
        Dim xFd As FileDialog
        Dim xFdItem As Variant
        Dim xFileName As String
        Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
        If xFd.Show = -1 Then
            xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
            xFileName = Dir(xFdItem & "*.xls*")
            Do While xFileName <> ""
                With Workbooks.Open(xFdItem & xFileName)
                   Windows("FO_001_Rev 00.xls").Activate
        Sheets("Change History ").Select
        Sheets("Change History ").Copy Before:=Workbooks(xFileName <> "").Sheets(1)
        Sheets("Change History ").Select
        Sheets("Change History ").Move After:=Sheets(2)
        Windows("FO_001_Rev 00.xls").Activate
        Sheets("NCR ").Select
        Sheets("NCR ").Copy Before:=Workbooks(xFileName <> "").Sheets(1)
        Sheets("NCR ").Select
        Sheets("NCR ").Move After:=Sheets(3)
        Sheets("NCR ").Select
        ActiveWorkbook.Save
                End With
                xFileName = Dir
            Loop
        End If
    End Sub

    Can anyone help please?

    Thanks 

    Monday, September 9, 2019 9:11 AM

All replies

  • Try this version:

    Sub LoopThroughFiles()
        Dim wbkS As Workbook
        Dim wbkT As Workbook
        Dim xFd As FileDialog
        Dim xFdItem As Variant
        Dim xFileName As String
        Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
        If xFd.Show Then
            Application.ScreenUpdating = False
            Set wbkS = Workbooks("FO_001_Rev 00.xls")
            xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
            xFileName = Dir(xFdItem & "*.xls*")
            Do While xFileName <> ""
                Set wbkT = Workbooks.Open(xFdItem & xFileName)
                wbkS.Worksheets("Change History ").Copy After:=wbkT.Worksheets(1)
                wbkS.Worksheets("NCR ").Copy After:=wbkT.Worksheets(2)
                wbkT.Close SaveChanges:=True
                xFileName = Dir
            Loop
            Application.ScreenUpdating = True
        End If
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, September 9, 2019 10:58 AM