VBA is there a way to speed up?

[BenGee]

Hi

My code below loops through 30+ workbooks saved in a server folder, and copy/pastes all data within each into a corresponding worksheet (each workbook has a matching worksheet name). It works but takes a bit of time.

Is there a way to improve the speed in which it executes? For example, avoiding selecting a range, copying and pasting? Any ideas or suggestions please;

My code;

Dim ws As Worksheet
Dim PathOfWorkbboks
Dim objFolder As Object
Dim objFile As Object
Dim Main
Dim ShtName, objName

Main = "Group reporting.xlsm"
         
Windows(Main).Activate
PathOfWorkbboks = "[REDACTED]"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(PathOfWorkbboks)
 
    For x = 1 To Sheets.Count
        With Sheets(x)
        Sheets(x).Activate
        ShtName = Mid(Sheets(x).Name, 1) & ".xlsx"
            For Each objFile In objFolder.Files
            objName = objFSO.Getfilename(objFile.Path)
            If objName = ShtName Then
               Workbooks.Open objFile
               Sheets("sheet1").Select
               Cells.Select
               Selection.Copy
               Windows(Main).Activate
               Range("A1:Q50").Select
               ActiveSheet.Paste
               Application.CutCopyMode = False
               Workbooks(objName).Close savechanges:=False
            End If
            Next
        End With
    Next x
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = True

Thanks in advance

 

[RoryA]

You might try something like:

Dim wbMain as Workbook
set wbMain = Workbooks("Group reporting.xlsm") ' use ThisWorkbook if it's the one with the code in
         
PathOfWorkbboks = "[REDACTED]"

    For x = 1 To wbMain.Sheets.Count
        With wbMain.Sheets(x)

        ShtName = Mid(.Name, 1) & ".xlsx"
        Dim filePath as string
        filepath = PathOfWorkbboks & shtname
            If Dir(filepath) <> vbnullstring then
            dim wb as workbook
              set wb = Workbooks.Open(filepath)
               wb.Sheets("sheet1").usedrange.Copy Destination:=.Range("A1")
               wb.Close savechanges:=False
            End If
        End With
    Next x

 

[jkpieterse]

Does this work any better?

Sub CopyAndSuch()
    Dim wb As Workbook
    Dim wbSource As Workbook
    Dim ws As Worksheet
    Dim PathOfWorkbboks
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim Main As String
    Dim ShtName As String
    Dim objName As Variant
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Main = "Group reporting.xlsm"
    Set wb = Workbooks(Main)
    
    PathOfWorkbboks = "[REDACTED]"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(PathOfWorkbboks)

    For Each ws In wb.Worksheets
        With ws
            'ws.Activate
            ShtName = Mid(ws.Name, 1) & ".xlsx"
            For Each objFile In objFolder.Files
                objName = objFSO.Getfilename(objFile.Path)
                If objName = ShtName Then
                    Set wbSource = Workbooks.Open(objFile)
                    wbSource.Sheets("sheet1").UsedRange.Cells.Copy
                    ws.Range("A1:Q50").Paste
                    Application.CutCopyMode = False
                    Workbooks(objName).Close savechanges:=False
                End If
            Next
        End With
    Next x

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[BenGee]

Thank you both for your suggestions.

RoryA, your solution has saved me some time. Thank you!

 

[RoryA]

Glad we could help!