Faster VBA Code for Importing data along with sum product calculations

[Monicasinha]

Hi

I am using the below code for
a. Opening a workbook,
b. Doing three calculations in that workbook ( Sum of columns, Product of two columns and divide by 12, Product of two columns)
c. Copy certain columns from this workbook to active workbook.

It takes little more than a minute to run the code. Can something be done to make it faster?

----------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Sub importDataFromAnotherWorkbook()

Dim ws As Worksheet

Dim filter As String

Dim targetWorkbook As Workbook, wb As Workbook

Dim Ret As Variant

Dim LR As Long

Const x As Long = 12

Dim cl As Range

Dim rng As Range, MyResultsRng(1) As Range

Dim destinationLastRow As Long, i As Long

Dim TotalCoverage As Double

Dim Totalhours As Double

Dim TotalRevenue As Double

Application.ScreenUpdating = False

---------------------------------------------------------------------------------------------

‘Get sheet

FileToOpen = Application.GetOpenFilename(filefilter:="Excelfiles(*.xlsx),*xls*")

Set Openbook = Application.Workbooks.Open(FileToOpen)
‘Get sum of Values from Column Z to Column EO in Column EY ( Row wise)

Const FirstCol As Long = 26 ' "Z"

Const LastCol As Long = 145 ' "EO"

destinationLastRow = Openbook.Sheets("SHEET 1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For i = 13 To destinationLastRow

Set MyResultsRng(1) = Openbook.Sheets("SHEET 1").Range("EY" & i)

For Each Cell In MyResultsRng(1)

Set rng = Openbook.Sheets("SHEET 1").Range(Openbook.Sheets("SHEET 1").Cells(i, FirstCol), Openbook.Sheets("SHEET 1").Cells(i, LastCol))

TotalCoverage = Application.WorksheetFunction.Sum(rng.Value)

With Cell

.Value = TotalCoverage

End With

Next Cell

Next i

Openbook.Sheets("SHEET 1").Range("EY13:EY5000").Copy

Openbook.Sheets("SHEET 1").Range("EY13:EY5000").PasteSpecial xlPasteValues

--------------------------------------------------------------------------------------------------------------------

‘Get product of Values from Column EY and Column EQ divided by 12 in Column EZ ( row wise)



For i = 13 To destinationLastRow

Set MyResultsRng(1) = Openbook.Sheets("SHEET 1").Range("EZ" & i)

For Each Cell In MyResultsRng(1)

Totalhours = Openbook.Sheets("SHEET 1").Range("EY" & i) / 12 * Openbook.Sheets("SHEET 1").Range("EQ" & i)

With Cell

.Value = Totalhours

End With

Next Cell

Next i

Openbook.Sheets("SHEET 1").Range("EZ13:EZ5000").Copy

Openbook.Sheets("SHEET 1").Range("EZ13:EZ5000").PasteSpecial xlPasteValues

Application.CutCopyMode = False

------------------------------------------------------------------------------------------------------------------------------------------
‘Get product of Values in Column EZ and Column ET in Column FA



For i = 13 To destinationLastRow

Set MyResultsRng(1) = Openbook.Sheets("SHEET 1").Range("FA" & i)

For Each Cell In MyResultsRng(1)

TotalRevenue = Openbook.Sheets("SHEET 1").Range("ET" & i) * Openbook.Sheets("SHEET 1").Range("EZ" & i)

With Cell

.Value = TotalRevenue

End With

Next Cell

Next i
---------------------------------------------------------------
Copy data from some columns from this workbook ( “Sheet 1”) to the active workbook



Openbook.Sheets("SHEET 1").Range("FA13:FA5000").Copy

Openbook.Sheets("SHEET 1").Range("FA13:FA5000").PasteSpecial xlPasteValues

Application.CutCopyMode = False

Openbook.Sheets("SHEET 1").Range("C13:C5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("D33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("H13:H5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("K33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("M13:M5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("L33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("E13:E5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("M33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("D13:D5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("S33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("EZ13:EZ5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("F33").PasteSpecial xlPasteValues

Openbook.Sheets("SHEET 1").Range("FA13:FA5000").Copy

ThisWorkbook.Worksheets("ACN Solution").Range("G33").PasteSpecial xlPasteValues

Application.CutCopyMode = False

'Openbook.Close False

'End If

Application.ScreenUpdating = True

MsgBox ("Data imported.")

End Sub

 

[johnnyL]

2 Questions:

1) do you still have
Const DestinationStartRow As Long = 13
in the code?

2) If you put the formula of
=ISBLANK(AH13)
in cell A1 on 'SHEET 1'
What is the result from the formula?

 

[Monicasinha]

1. yES
2. I get "False" even though cell appears as blank. If I hit delete and then put the formula it is "TRUE"

 

[johnnyL]

Do you have formulas in the Z:EO range?

 

[Monicasinha]

Do you have formulas in the Z:EO range?

No

 

[johnnyL]

Ok. Here is a version that will check for numbers prior to doing calculations. That should handle the 'Blank' cells which are not actually Blank.

Sub importDataFromAnotherWorkbookV2()
'
    Dim TotalCoverage           As Double
    Dim ArrayColumn             As Long, ArrayRow           As Long
    Dim destinationLastRow      As Long
    Dim Columns_C_Thru_H_Array  As Variant, Column_M_Array  As Variant, Columns_Z_Thru_FA_Array     As Variant
    Dim TempArray()             As Variant
'
    Const DestinationStartRow   As Long = 13
'
    Application.ScreenUpdating = False                                                                                      ' Turn ScreenUpdating off
'---------------------------------------------------------------------------------------------
'
' Get Sheet
    FileToOpen = Application.GetOpenFilename(filefilter:="Excelfiles(*.xlsx),*xls*")
'
    Set Openbook = Application.Workbooks.Open(FileToOpen)
'
'---------------------------------------------------------------------------------------------
' Get sum of Values from Column Z to Column EO into Column EY ( Row wise)
'
    destinationLastRow = Openbook.Sheets("SHEET 1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' Get last row in 'SHEET 1'
'
    Columns_Z_Thru_FA_Array = Openbook.Sheets("SHEET 1").Range("Z" & DestinationStartRow & ":FA" & destinationLastRow)      ' Columns 1 - 120 = Z:EO, Column 122 = EQ, Column 125 = ET, Columns 130 - 132 = EY:FA
'
    For ArrayRow = 1 To UBound(Columns_Z_Thru_FA_Array, 1)                                                                  ' Loop through the rows of Columns_Z_Thru_FA_Array
        For ArrayColumn = 1 To 120                                                                                          '   Loop through Columns 1 through 120 of Columns_Z_Thru_FA_Array ie. Z:EO
            If IsNumeric(Columns_Z_Thru_FA_Array(ArrayRow, ArrayColumn)) Then TotalCoverage = _
                    TotalCoverage + Columns_Z_Thru_FA_Array(ArrayRow, ArrayColumn)                                          '       Keep a running total of all values in the row
        Next                                                                                                                '   Loop back
'
        Columns_Z_Thru_FA_Array(ArrayRow, 130) = TotalCoverage                                                              '   Save the running total to Column 130 of Columns_Z_Thru_FA_Array ie. EY
        TotalCoverage = 0                                                                                                   '   Reset TotalCoverage
    Next                                                                                                                    ' Loop back
'
'--------------------------------------------------------------------------------------------------------------------
'
' Get product of Values from Column EY and Column EQ divided by 12 into Column EZ ( row wise)
'
    For ArrayRow = 1 To UBound(Columns_Z_Thru_FA_Array, 1)                                                                  ' Loop through the rows of Columns_Z_Thru_FA_Array
        If IsNumeric(Columns_Z_Thru_FA_Array(ArrayRow, 130)) And IsNumeric(Columns_Z_Thru_FA_Array(ArrayRow, 122)) Then
            Columns_Z_Thru_FA_Array(ArrayRow, 131) = Columns_Z_Thru_FA_Array(ArrayRow, 130) / 12 * _
                    Columns_Z_Thru_FA_Array(ArrayRow, 122)                                                                  '   Save result (Totalhours) to Column 131 of Columns_Z_Thru_FA_Array ie. EZ
        End If
    Next                                                                                                                    ' Loop back
'
'------------------------------------------------------------------------------------------------------------------------------------------
'
' Get product of Values in Column EZ and Column ET into Column FA
'
    For ArrayRow = 1 To UBound(Columns_Z_Thru_FA_Array, 1)                                                                  ' Loop through the rows of Columns_Z_Thru_FA_Array
        If IsNumeric(Columns_Z_Thru_FA_Array(ArrayRow, 125)) And IsNumeric(Columns_Z_Thru_FA_Array(ArrayRow, 131)) Then
            Columns_Z_Thru_FA_Array(ArrayRow, 132) = Columns_Z_Thru_FA_Array(ArrayRow, 125) * _
                    Columns_Z_Thru_FA_Array(ArrayRow, 131)                                                                  '   Save result (TotalRevenue) to Column 132 of Columns_Z_Thru_FA_Array ie. FA
        End If
    Next                                                                                                                    ' Loop back
'
'---------------------------------------------------------------
'
' Copy Columns_Z_Thru_FA_Array back to Openbook.Sheets("SHEET 1")
'
    Openbook.Sheets("SHEET 1").Range("Z" & DestinationStartRow).Resize(UBound(Columns_Z_Thru_FA_Array, 1), _
            UBound(Columns_Z_Thru_FA_Array, 2)) = Columns_Z_Thru_FA_Array                                                   '
'
'---------------------------------------------------------------
'
' Copy data from some columns from this workbook ( "Sheet 1") to the active workbook
'
    ReDim TempArray(1 To UBound(Columns_Z_Thru_FA_Array, 1), 1 To 1)
'
    For ArrayRow = 1 To UBound(Columns_Z_Thru_FA_Array, 1)                                                                  ' Loop through the rows of Columns_Z_Thru_FA_Array
        TempArray(ArrayRow, 1) = Columns_Z_Thru_FA_Array(ArrayRow, 131)                                                     '   Copy Column 131 of Columns_Z_Thru_FA_Array ie. EZ to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("F33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column F of Sheet 'ACN Solution'
'
'
    ReDim TempArray(1 To UBound(Columns_Z_Thru_FA_Array, 1), 1 To 1)                                                        ' Erase TempArray
'
    For ArrayRow = 1 To UBound(Columns_Z_Thru_FA_Array, 1)                                                                  ' Loop through the rows of Columns_Z_Thru_FA_Array
        TempArray(ArrayRow, 1) = Columns_Z_Thru_FA_Array(ArrayRow, 132)                                                     '   Copy Column 132 of Columns_Z_Thru_FA_Array ie. FA to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("G33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column G of Sheet 'ACN Solution'
'
    Erase Columns_Z_Thru_FA_Array                                                                                           ' Free up the memory that Columns_Z_Thru_FA_Array was consuming
'
'---------------------------------------------------------------
'
    Columns_C_Thru_H_Array = Openbook.Sheets("SHEET 1").Range("C" & DestinationStartRow & ":H" & destinationLastRow)        ' Columns 1 - 6 = C:H
'
    ReDim TempArray(1 To UBound(Columns_C_Thru_H_Array, 1), 1 To 1)
'
    For ArrayRow = 1 To UBound(Columns_C_Thru_H_Array, 1)                                                                   ' Loop through the rows of Columns_C_Thru_H_Array
        TempArray(ArrayRow, 1) = Columns_C_Thru_H_Array(ArrayRow, 1)                                                        '   Copy Column 1 of Columns_C_Thru_H_Array ie. C to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("D33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column D of Sheet 'ACN Solution'
'
'
    ReDim TempArray(1 To UBound(Columns_C_Thru_H_Array, 1), 1 To 1)                                                         ' Erase the TempArray
'
    For ArrayRow = 1 To UBound(Columns_C_Thru_H_Array, 1)                                                                   ' Loop through the rows of Columns_C_Thru_H_Array
        TempArray(ArrayRow, 1) = Columns_C_Thru_H_Array(ArrayRow, 2)                                                        '   Copy Column 2 of Columns_C_Thru_H_Array ie. D to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("S33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column S of Sheet 'ACN Solution'
'
'
    ReDim TempArray(1 To UBound(Columns_C_Thru_H_Array, 1), 1 To 1)                                                         ' Erase the TempArray
'
    For ArrayRow = 1 To UBound(Columns_C_Thru_H_Array, 1)                                                                   ' Loop through the rows of Columns_C_Thru_H_Array
        TempArray(ArrayRow, 1) = Columns_C_Thru_H_Array(ArrayRow, 3)                                                        '   Copy Column 3 of Columns_C_Thru_H_Array ie. E to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("M33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column M of Sheet 'ACN Solution'
'
'
    ReDim TempArray(1 To UBound(Columns_C_Thru_H_Array, 1), 1 To 1)                                                         ' Erase the TempArray
'
    For ArrayRow = 1 To UBound(Columns_C_Thru_H_Array, 1)                                                                   ' Loop through the rows of Columns_C_Thru_H_Array
        TempArray(ArrayRow, 1) = Columns_C_Thru_H_Array(ArrayRow, 6)                                                        '   Copy Column 6 of Columns_C_Thru_H_Array ie. H to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("K33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column K of Sheet 'ACN Solution'
'
    Erase Columns_C_Thru_H_Array                                                                                            ' Free up the memory that Columns_C_Thru_H_Array was consuming
'
'---------------------------------------------------------------
'
    Column_M_Array = Openbook.Sheets("SHEET 1").Range("M" & DestinationStartRow & ":M" & destinationLastRow)                ' Column 1 = M
'
    ReDim TempArray(1 To UBound(Column_M_Array, 1), 1 To 1)
'
    For ArrayRow = 1 To UBound(Column_M_Array, 1)                                                                           ' Loop through the rows of Column_M_Array
        TempArray(ArrayRow, 1) = Column_M_Array(ArrayRow, 1)                                                                '   Copy Column 1 of Column_M_Array ie. M to TempArray
    Next                                                                                                                    ' Loop back
'
    ThisWorkbook.Worksheets("ACN Solution").Range("L33").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray     ' Display the TempArray to Column L of Sheet 'ACN Solution'
'
    Erase Column_M_Array                                                                                                    ' Free up the memory that Column_M_Array was consuming
    Erase TempArray                                                                                                         ' Free up the memory that TempArray was consuming
'
'Openbook.Close False

'End If

    Application.ScreenUpdating = True                                                                                       ' Turn ScreenUpdating back on
'
    MsgBox ("Data imported.")
End Sub

 

[Monicasinha]

This is excellent! Time reduced to just 10 seconds from earlier solution of around 40 seconds.
Thank you so much!

 

[johnnyL]

Thank you for responding back @Monicasinha