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

 

[DanteAmor]

Try this:

Sub importDataFromAnotherWorkbook()
  Dim Openbook As Workbook
  Dim shACN As Worksheet, sh1 As Worksheet
  Dim rng As Range
  Dim destinationLastRow As Long, i As Long, nRows As Long
  Dim TotalCoverage As Double, Totalhours As Double, TotalRevenue As Double
  Dim FileToOpen As Variant
 
  Application.ScreenUpdating = False
 
  Set shACN = ThisWorkbook.Sheets("ACN Solution")
  '---------------------------------------------------------------------------------------------
  'Get Sheet
  FileToOpen = Application.GetOpenFilename(filefilter:="Excelfiles(*.xlsx),*xls*")
  Set Openbook = Application.Workbooks.Open(FileToOpen)
 
  Set sh1 = Openbook.Sheets("SHEET 1")
 
  '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 = sh1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
  For i = 13 To destinationLastRow
    Set rng = sh1.Range(sh1.Cells(i, FirstCol), sh1.Cells(i, LastCol))
    TotalCoverage = Application.WorksheetFunction.Sum(rng.Value)
    sh1.Range("EY" & i).Value = TotalCoverage
   
    Totalhours = sh1.Range("EY" & i) / 12 * sh1.Range("EQ" & i)
    sh1.Range("EZ" & i).Value = Totalhours
   
    TotalRevenue = sh1.Range("ET" & i) * sh1.Range("EZ" & i)
    sh1.Range("FA" & i).Value = TotalRevenue
  Next i
 
  nRows = destinationLastRow - 13 + 1
  shACN.Range("D33").Resize(nRows).Value = sh1.Range("C13").Resize(nRows).Value
  shACN.Range("K33").Resize(nRows).Value = sh1.Range("H13").Resize(nRows).Value
  shACN.Range("L33").Resize(nRows).Value = sh1.Range("M13").Resize(nRows).Value
  shACN.Range("M33").Resize(nRows).Value = sh1.Range("E13").Resize(nRows).Value
  shACN.Range("S33").Resize(nRows).Value = sh1.Range("D13").Resize(nRows).Value
  shACN.Range("F33").Resize(nRows).Value = sh1.Range("EZ13").Resize(nRows).Value
  shACN.Range("G33").Resize(nRows).Value = sh1.Range("FA13").Resize(nRows).Value
 
  Application.ScreenUpdating = True
  MsgBox ("Data imported.")
End Sub

Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.

---

 

[johnnyL]

This is the second time that I also suggest using code tags when submitting your code.
Please use code tags as @DanteAmor also has suggested.

That being said, I offer an alternative approach that uses arrays. This is untested, ie. all done in my head, please test on a copy of your workbooks to see if it does what you want it to do.

Sub importDataFromAnotherWorkbook()
'
    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
            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
        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
    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
        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
    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

I would think that approach would be faster.

 

[Monicasinha]

Hi Johnny- I tried with the code you gave, but it got stuck on the line

TotalCoverage = TotalCoverage + Columns_Z_Thru_FA_Array(ArrayRow, ArrayColumn)

with the error "type mismatch"

Thanks

 

[johnnyL]

What is the value of ArrayRow & ArrayColumn @ that point of the error?

 

[johnnyL]

Or better yet, offer up some data that we can test via xl2bb.

 

[Monicasinha]

What is the value of ArrayRow & ArrayColumn @ that point of the error?

Array row is 1 and Array column is 9

Note that the data is in Column 26 to 145 and row 9 onwards

 

[Monicasinha]

Array row is 1 and Array column is 9

Note that the data is in Column 26 to 145 and row 9 onwards

Columns EY ( sum of rows), EZ ( EY*Values in EQ/12) and FA ( EZ*ET) is where I was just doing the calculation

 

[johnnyL]

Array row is 1 and Array column is 9

Note that the data is in Column 26 to 145 and row 9 onwards

The column 9 indicates The AH column on the sheet. What data do you have in the AH column?

 

[Monicasinha]

some snapshots of the sheet..