CODEWITHSUNDEEP
excelvba
Afikasky
Afikasky

Reputation: 133

Loop through multiple files in a folder a copy and paste from a specific worksheet into a MASTER file

I'm trying to loop through files in a folder with following path "C:\Users\Ouen\Downloads\Test" and paste each output into a new specific sheet in a MASTER workbook.

For example, the below are all the same worksbooks that each have a specific worksheet called "Annual" with different outputs:

Asset1
Asset2
Asset3
Etc

I would like to copy the whole Annual worksheet from each of the workbooks above and paste into a MASTER workbook, while being able to rename them to the following:

Asset1 - Annual
Asset2 - Annual
Asset3 - Annual 
Etc

I have had some luck in copying and pasting from each workbook into the master but I'm unable to to paste each output into a new worksheet within the master and rename. Any ideas?

Sub Assets2Master()
        Dim xRg As Range
        Dim xSelItem As Variant
        Dim xFileDlg As FileDialog
        Dim xFileName, xSheetName, xRgStr As String
        Dim xBook, xWorkBook As Workbook
        Dim xSheet As Worksheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        xSheetName = "Annual"
        xRgStr = "B1:GI100"
        Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
        With xFileDlg
            If .Show = -1 Then
                xSelItem = .SelectedItems.Item(1)
                Set xWorkBook = ThisWorkbook
                Set xSheet = xWorkBook.Sheets("MASTER")
                If xSheet Is Nothing Then
                    xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "MASTER"
                    Set xSheet = xWorkBook.Sheets("MASTER")
                End If
                xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
                If xFileName = "" Then Exit Sub
                Do Until xFileName = ""
                   Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                    Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                    xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                    xFileName = Dir()
                    xBook.Close
                Loop
            End If
        End With
        et xRg = xSheet.UsedRange   
    xRg.ClearFormats    
    xRg.UseStandardHeight = True    
    xRg.UseStandardWidth = True 
    Application.DisplayAlerts = True    
    Application.EnableEvents = True 
    Application.ScreenUpdating = True
    End Sub

Upvotes: 2

Views: 660

Answers (3)

norie
norie

Reputation: 9857

Copy to the end

This code will copy, if it exists, the Annual worksheet from each workbook in the folder you select via the dialog.

They will be copied to the workbook the code is in and the copied sheets will be renamed with the name of the workbook they came from appended with - Annual.

The copied sheets will be copied after the last sheet in the MASTER workbook.

Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

    With dlg
        If .Show = -1 Then
            strFolder = .SelectedItems.Item(1)
        End If
    End With

    Set wbDst = ThisWorkbook

    strFileName = Dir(strFolder & "\*.xlsx", vbNormal)

    If strFileName = "" Then Exit Sub

    Do Until strFileName = ""

        If strFileName <> wbDst.Name Then
            Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)

            ' check if 'Annual' sheet exists, and if it does copy it to master workbook
            If IfSheetExists("Annual", wbSrc) Then

                Set wsSrc = wbSrc.Sheets("Annual")

                With wbDst
                    wsSrc.Copy After:=.Sheets(.Sheets.Count)
                    .Sheets(.Sheets.Count).Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
                End With

            End If

            wbSrc.Close SaveChanges:=False
        End If
        
        strFileName = Dir()

    Loop

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet

    If wb Is Nothing Then
        Set wb = ActiveWorkbook
    End If

    For Each ws In wb.Sheets
        If ws.Name = strName Then
            IfSheetExists = True
            Exit For
        End If
    Next ws

End Function

Copy after specific sheet

This code is basically identical to the previous code but the workheets will be copied after a specific worksheet in the MASTER workbook.

Option Explicit

Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String
Dim lngDstIndex As Long

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

    With dlg
        If .Show = -1 Then
            strFolder = .SelectedItems.Item(1)
        End If
    End With

    Set wbDst = ThisWorkbook
    
    ' change Specific Tab to the name ypu want the sheets to be copied after
    lngDstIndex = wbDst.Sheets("Specific Tab").Index

    strFileName = Dir(strFolder & "\*.xlsx", vbNormal)

    If strFileName = "" Then Exit Sub

    Do Until strFileName = ""

        If strFileName <> wbDst.Name Then
            Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)

            ' check if 'Annual' sheet exists, and if it does copy it to master workbook
            If IfSheetExists("Annual", wbSrc) Then

                Set wsSrc = wbSrc.Sheets("Annual")

                With wbDst
                    ' copy sheet to MASTER workbook
                    wsSrc.Copy After:=.Sheets(.Sheets.Count)
                    ' rename sheet and move it after specified sheet
                    With .Sheets(.Sheets.Count)
                        .Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
                        .Move After:=wbDst.Sheets(lngDstIndex)
                        lngDstIndex = lngDstIndex + 1
                    End With
                End With

            End If

            wbSrc.Close SaveChanges:=False
        End If
        
        strFileName = Dir()

    Loop

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet

    If wb Is Nothing Then
        Set wb = ActiveWorkbook
    End If

    For Each ws In wb.Sheets
        If ws.Name = strName Then
            IfSheetExists = True
            Exit For
        End If
    Next ws

End Function

Upvotes: 2

VBasic2008
VBasic2008

Reputation: 54807

Stack Ranges

  • This is about what I thought your code was supposed to do. What you asked for is kind of illustrated with the commented block of code in the Do...Loop. By modifying the code in the Do...Loop, there are many possibilities of what you could achieve.
Option Explicit

Sub StackRanges()
    
    ' Source
    Const sName As String = "Sheet1" ' "Annual"
    Const sAddress As String = "B1:GI100"
    
    ' Destination
    Const dName As String = "MASTER"
    Const dCol As String = "A"
    
    Application.ScreenUpdating = False
   
    ' Open the dialog to pick a folder.
    Dim xFileDlg As FileDialog
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    Dim sFolderPath As Variant
    With xFileDlg
        .InitialFileName = ThisWorkbook.Path
        If .Show = True Then
            sFolderPath = .SelectedItems.Item(1)
        Else
            MsgBox "Canceled.", vbExclamation, "Assets2Master"
            Exit Sub
        End If
    End With
            
    ' Write the name of the first file to the Source File Name variable.
    Dim sfName As String: sfName = Dir(sFolderPath & "\*.xlsx")
    
    ' Validate first Source File Name.
    If Len(sfName) = 0 Then Exit Sub ' no files found
            
    ' Create a reference to the Destination Workbook.
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    ' Write the name of the Destination Workbook
    ' to the Destination File Name variable.
    Dim dfName As String: dfName = dwb.Name
    
    ' Attempt to create a reference to the Destination Worksheet.
    Dim dws As Worksheet
    On Error Resume Next
    Set dws = dwb.Worksheets(dName)
    On Error GoTo 0
    
    ' If the attempt was unsuccessful, add a new worksheet and do it now.
    If dws Is Nothing Then
        dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count)).Name = dName
        Set dws = dwb.Worksheets(dName)
        ' Maybe add some headers... to the Destination Worksheet.
    End If
    
    ' Create a reference to the (first) Destination Range.
    Dim drg As Range: Set drg = dws.Range(sAddress)
    Dim rCount As Long: rCount = drg.Rows.Count
    Dim cCount As Long: cCount = drg.Columns.Count
    Set drg = dws.Cells(dws.Rows.Count, dCol).End(xlUp) _
        .Offset(1, 0).Resize(rCount, cCount)
    
    ' Declare additional variables for the following 'Do Loop'.
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    
    ' Loop through the files in the folder...
    Do Until Len(sfName) = 0
            
        ' Check if the Source File Name is different
        ' than the Destination File Name.
        If StrComp(sfName, dfName, vbTextCompare) <> 0 Then
        
            ' Open and create a reference to the Source Workbook.
            Set swb = Workbooks.Open(sFolderPath & "\" & sfName)
            
            ' Attempt to create a reference to the Source Worksheet.
            Set sws = Nothing
            On Error Resume Next
            Set sws = swb.Worksheets(sName)
            On Error GoTo 0
            
            ' Stack Ranges
            
            ' If the attempt was successful...
            If Not sws Is Nothing Then
                ' Create a reference to the Source Range.
                Set srg = sws.Range(sAddress)
                ' Copy the values from the Source to the Destination Range
                ' by assignment.
                drg.Value = srg.Value
                ' Create a reference to the (next) Destination Range.
                Set drg = drg.Offset(rCount)
            End If
            
'            ' Copy Worksheets (instead)
'
'            ' If the attempt was successful...
'            If Not sws Is Nothing Then
'                sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
'                ' Caution: Has to be less than 32 characters!
'                ActiveSheet.Name = Left(sfName, Len(sfName) - 5) & " - " & sName
'            End If
            
            ' Close the Source Workbook.
            swb.Close SaveChanges:=False
        
        End If
        
        ' Write the name of the next file to the Source File Name variable.
        sfName = Dir
    
    Loop
    
    Application.ScreenUpdating = True
    
    ' Inform the user.
    MsgBox "Data copied.", vbInformation, "Assets2Master"

End Sub

Upvotes: 2

ferJen
ferJen

Reputation: 97

Try this. The Master wb should be placed in a different folder than the one you store the Asset Files:

Sub Assets2Master()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    xSheetName = "Annual"
    xRgStr = "B1:GI100"
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.item(1)
            Set xWorkBook = ActiveWorkbook
            Set xSheet = xWorkBook.Sheets("MASTER")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(After:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "MASTER"
                Set xSheet = xWorkBook.Sheets("MASTER")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
                Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
                xBook.Name = xBook.Name & " - Annual"
            Loop
        End If
    End With
    Set xRg = xSheet.UsedRange
    xRg.ClearFormats
    xRg.UseStandardHeight = True
    xRg.UseStandardWidth = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Upvotes: 2

Related Questions