Faster VBA Code for Importing data along with sum product calculations

M

Monicasinha

Board Regular
Joined
Dec 26, 2022
Messages
51
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Try this:

VBA Code: 
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.

---
 
Upvote 0
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.

VBA Code: 
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.
 
Upvote 0
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
 
Upvote 0
What is the value of ArrayRow & ArrayColumn @ that point of the error?
 
Upvote 0
Or better yet, offer up some data that we can test via xl2bb.
 
Upvote 0
Monicasinha said:
Array row is 1 and Array column is 9

Note that the data is in Column 26 to 145 and row 9 onwards
Click to expand...
The column 9 indicates The AH column on the sheet. What data do you have in the AH column?
 
Upvote 0
1673028999997.png

1673029318551.png

some snapshots of the sheet..
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Trying to copy data from a specific sheet in one workbook to another with VBA
Replies
2
Views
177
druck21
D
T
  • Solved
Import Data Starting from next empty row
Replies
7
Views
478
Tanne
T
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
SandsB
  • Question Question
Why does "Step Into" stop after I open my input file?
Replies
4
Views
546
SandsB
SandsB
R
  • Solved
VBA code to find cells with any value and replace with blank
Replies
5
Views
827
Jeffrey Mahoney
Jeffrey Mahoney

Forum statistics

Threads
1,224,828
Messages
6,181,212
Members
453,023
Latest member
alabaz

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top