Gfrktyl

I have this code which opens 2 workbooks, copies a sheet and paste then to the master workbook. It is currently taking 3 minutes. Can this be done quicker (i.e. without opening each workbook to copy)?

It takes roughly 3 minutes to do.

Sub Load()

    Dim masterWB As Workbook

    Dim dailyWB As Workbook

    Dim lastweekWB As Workbook

    Dim R As Range

    Dim B As Range

    Dim C As Range

    Dim Lrow As Long



    Application.DisplayAlerts = False



    'Set Current Workbook as Master

    Set masterWB = Application.ThisWorkbook

    'Set some Workbook as the one you are copying from

    Set dailyWB = Workbooks.Open(Sheets("Control Manager").Range("O2"))



    'Copy the Range from dailyWB and Paste it into the MasterWB

    dailyWB.Sheets("Summary1").Range("A1:BJ200").Copy masterWB.Sheets("Summary").Range("A1").Rows("1:1")

    'formatting and paste as values

    masterWB.Activate

    Worksheets("Summary").Select

    'trim values

    Columns("A:BJ").Select

    Selection.Columns.AutoFit

    Selection.Copy

    Selection.PasteSpecial xlPasteValues



    'repeat for next Sheet

    dailyWB.Sheets("risk1").Range("A1:BB200").Copy masterWB.Sheets("risk").Range("A1").Rows("1:1")

    'formatting and paste as values'

    masterWB.Activate

    Worksheets("risk").Select

    Columns("A:BB").Select

    With Application.WorksheetFunction

        For Each B In Intersect(Columns("A:BB"), ActiveSheet.UsedRange)

            B.Value = .Trim(B.Value)

        Next B

    End With

    Selection.Columns.AutoFit

    Selection.Copy

    Selection.PasteSpecial xlPasteValues



    'repeat for CS sheet

    dailyWB.Sheets("CS today").Range("A1:L3").Copy masterWB.Sheets("CS").Range("A1").Rows("1:1")

    'formatting and paste as values

    masterWB.Activate

    Worksheets("CS").Select

    Columns("A:L").Select

    'trim cells to exclude spaces.

    With Application.WorksheetFunction

        For Each R In Intersect(Columns("A:L"), ActiveSheet.UsedRange)

            R.Value = .Trim(R.Value)

        Next R

    End With

    Selection.Columns.AutoFit

    Selection.Copy

    Selection.PasteSpecial xlPasteValues



    ''''''''''''Get Last Week Data''''''''''''''''''''''



    Set lastweekWB = Workbooks.Open(Sheets("Control Manager").Range("O3"))



    'repeat for next risk Sheet

    lastweekWB.Sheets("risk2").Range("A1:BB200").Copy masterWB.Sheets("risk_lastweek").Range("A1").Rows("1:1")

    'formatting and paste as values



    masterWB.Activate

    Worksheets("risk_lastweek").Select

    Columns("A:BB").Select

    With Application.WorksheetFunction

        For Each B In Intersect(Columns("A:BB"), ActiveSheet.UsedRange)

            B.Value = .Trim(B.Value)

        Next B

    End With

    Selection.Columns.AutoFit

    Selection.Copy

    Selection.PasteSpecial xlPasteValues



    Application.DisplayAlerts = True



    'Close the Workbook without saving

    dailyWB.Close False

    lastweekWB.Close False

    'Clear the Variables

    Set dailyWB = Nothing

    Set masterWB = Nothing

    Set lastweekWB = Nothing

End Sub

Separating tasks into multiple subroutines will make the code easier to test and modify.

This video: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset) will explain why you rarely need to Select or Activate an Object.

I would use .Range("A1") instead of .Range("A1").Rows("1:1") because Range.Copy targets the first cell in the destination.

Refactored Code

Sub Load()

    LoadDailyWorkbook

    LoadLastWeeksWorkbook

End Sub



Sub LoadDailyWorkbook()

    Const A1BJ200 As String = "A1:BJ200"

    Const A1L3 As String = "A1:L3"

    Dim masterWB As Workbook

    Dim dailyWB As Workbook

    'Set Current Workbook as Master

    Set masterWB = Application.ThisWorkbook

    'Set some Workbook as the one you are copying from

    Set dailyWB = getWorkbook(Sheets("Control Manager").Range("O2"))



    If Not dailyWB Is Nothing Then

        With dailyWB

            'Copy the Range from dailyWB and Paste it into the MasterWB

            .Worksheets("Summary1").Range(A1BJ200).Copy masterWB.Worksheets("Summary").Range("A1")

            TrimRange masterWB.Worksheets("Summary").Range(A1BJ200)

            'repeat for next Sheet

            .Worksheets("risk1").Range(A1BJ200).Copy masterWB.Worksheets("risk").Range("A1")

            TrimRange masterWB.Worksheets("risk").Range(A1BJ200)



            'repeat for CS sheet

            .Worksheets("CS today").Range(A1L3).Copy masterWB.Worksheets("CS").Range("A1").Rows("1:1")

            TrimRange masterWB.Worksheets("CS").Range(A1L3)

            .Close SaveChanges:=False

        End With



    End If

End Sub



Sub LoadLastWeeksWorkbook()

    Const A1BJ200 As String = "A1:BJ200"

    Dim masterWB As Workbook

    Dim lastweekWB As Workbook



    'Set Current Workbook as Master

    Set masterWB = Application.ThisWorkbook



    ''''''''''''Get Last Week Data''''''''''''''''''''''

    Set lastweekWB = getWorkbook(Workbooks.Open(Sheets("Control Manager").Range("O3")))

    If Not lastweekWB Is Nothing Then

        With lastweekWB

            'repeat for next risk Sheet

            .Worksheets("risk2").Range(A1BJ200).Copy masterWB.Worksheets("risk_lastweek").Range("A1")

            TrimRange masterWB.Worksheets("risk_lastweek").Range(A1BJ200)



            TrimRange masterWB.Columns("A:BB")

            .Close SaveChanges:=False

        End With

    End If

End Sub



Function getWorkbook(FullName As String) As Workbook

    If Len(Dir(FullName)) = 0 Then

        MsgBox FullName & " not found found", vbCritical, "File Not Found"

    Else

        Set getWorkbook = Workbooks.Open(FullName)

    End If

End Function



Sub TrimRange(Target As Range)

    Dim results As Variant

    Set Target = Intersect(Target.Parent.UsedRange, Target)

    If Target Is Nothing Then

        Exit Sub

    ElseIf Target.Count = 1 Then

        Target.Value = Trim(Target.Value)

        Exit Sub

    Else

        results = Target.Value



        Dim r As Long, c As Long

        For r = 1 To UBound(results)

            For c = 1 To UBound(results, 2)

                results(r, c) = Trim(results(r, c))

            Next

        Next

        Target.Value = results

    End If

    Target.Columns.EntireColumn.AutoFit

End Sub