Vlookup vb code taking a lot of time

A

avid.excel.user

New Member
Joined
Dec 29, 2010
Messages
23
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
hi guys

we have designed a macro to do a vlookup function through various sheets, the concern is that the time taken for the vlookup to run is very huge. If there is any shorter way to do this then please revert. The vlookup is running on around 4000 rows and the data table for reference is around 5000 rows.

the piece of code is atatched for your reference and views.

ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-31],[Close.xls]Data!C6,1,0)),1,0)"
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
To be fair, that's not a macro doing the vlookup, but that aside, what about the rest of your code?

How are you inserting the formulas? All at once, or 1 at a time?

Are you selecting cells before pasting the formula (looks like you are)

Have you disabled screen updating before running this code?

All these things will have an impact on execution time.

Best thing is to post all your code and let's have a look at it.

HTH
 
Upvote 0
Dear Weaver,

Thank u soo much for ur revert. Actually i am exactly doing the same as u have mentioned, due to the limited knowledge of excel macro that i have attaching the complete piece of the code for your views:

Basically, i am referring to multiple wrok books and slicing band dicing with pivoting then\ database to arrive the output.

Private Sub txtfilename_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
filetoopen = Application _
.GetOpenFilename("Excel files(*.*),*.xls")
If filetoopen <> False Then
txtfilename.Value = filetoopen
Workbooks.Open txtfilename.Value
'Change Worksheet Name
ActiveSheet.Name = "data"
'' Correct Account Number to 14 digits
Rows("1:1").Select
Selection.Find(What:="accNo", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Font.Bold = True
ActiveCell.Offset(0, 1).Select
ActiveCell.EntireColumn.Insert
ActiveCell.Value = "Account No"
ActiveCell.Offset(1, 0).Select
Do
ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""00000000000000"")"
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Offset(0, 1))
Selection.End(xlUp).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, 1).Select
ActiveCell.EntireColumn.Select
Selection.Delete Shift:=xlToLeft
' Correct Product code field that is remove L from starting
Rows("1:1").Select
Selection.Find(What:="codProduct", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Font.Bold = True
ActiveCell.EntireColumn.Select
Selection.Replace What:="L", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Consider Product Code flage at the right side of data
Rows("1:1").Select
Selection.Find(What:="codProduct", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Font.Bold = True
ActiveCell.EntireColumn.Copy
ActiveCell.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Product Code"
ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
MsgBox ("Open Product Code File")
Prodcodefile = Application.GetOpenFilename("Excel Files(*.xls),*.xls")
Do
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-1],'[Approv Product Data.xls]Product Code'!c2,1,0)),0,1)"
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Offset(0, -1))
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, -1).Select
ActiveCell.EntireColumn.Select
Selection.Delete Shift:=xlToLeft

'Consider Amount Record flag
ActiveCell.Offset(0, 1).Select
Rows("1:1").Select
Selection.Find(What:="AmtCrMADB", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.EntireColumn.Copy
ActiveCell.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Consider AMT"
ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]<499999,0,1)"
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Insert range of AmtcrMADB 5 Lac and 10 Lac
ActiveCell.Offset(0, 1).Select
ActiveCell.Font.Bold = True
ActiveCell.Value = "Range of CrMADB"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]<0,""Less than Zero"",IF(RC[-2]<499999,""Less than 5L"",IF(RC[-2]<999999,""Greater than 5L"",""Greater than 10L"")))"
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, -2).Select
ActiveCell.EntireColumn.Select
Selection.Delete Shift:=xlToLeft

'Consider LOB Flag for Sales, Branch, Privy
Rows("1:1").Select
Selection.Find(What:="CodSourcingLOB", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.EntireColumn.Copy
ActiveCell.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Consider LOB"
ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[-1]=51,RC[-1]=52,RC[-1]=55,RC[-1]=99),1,0)"
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
' Insert Channel Type field update throght CodSourcingLOB Field
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Channel"
ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]=51,""Branch"",IF(RC[-2]=52,""Sales"",IF(RC[-2]=55,""Privy"",""other"")))"
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(0, -2).Select
ActiveCell.EntireColumn.Select
Selection.Delete Shift:=xlToLeft

'Live Accounts Flag
ActiveCell.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Font.Bold = True
ActiveCell.Value = "Live"
ActiveCell.Offset(1, 0).Select
MsgBox ("Open Attritions File")
closefile = Application.GetOpenFilename("Excel Files(*.xls),*.xls")
Do
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-31],[Close.xls]Data!C6,1,0)),1,0)"
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Offset(0, -1))
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Consider Record Flag
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Consider Record"
ActiveCell.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-3]*RC[-5]*RC[-6]"
ActiveCell.SpecialCells(xlLastCell).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
ActiveCell.EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

'Pivot Code for Data2
Cells(1, 1).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Sheets.Add

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"data!R1C1:R5920C39", Version:=xlPivotTableVersion10).CreatePivotTable _
TableDestination:="Sheet1!R3C1", TableName:="PivotTable3", DefaultVersion _
:=xlPivotTableVersion10
Sheets("Sheet1").Select
With ActiveSheet.PivotTables("PivotTable3").PivotFields("CodBranch")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Consider Record")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Range of CrMADB")
.Orientation = xlColumnField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Channel")
.Orientation = xlColumnField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _
"PivotTable3").PivotFields("AccNo"), "Count of AccNo", xlCount
ActiveCell.Offset(12, 3).Range("A1").Select
With ActiveSheet.PivotTables("PivotTable3")
.NullString = "0"
.ShowDrillIndicators = False
End With
ActiveSheet.PivotTables("PivotTable3").PivotFields("Consider Record"). _
CurrentPage = "1"
ActiveSheet.Name = "Pivot1"
Sheets("Pivot1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Data2"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Sheets("Data2").Activate
If ActiveCell.Range("C5").Value = "Sales" Then
ActiveCell.Range("c5").Select
ActiveCell.EntireColumn.Insert
ActiveCell.Value = "Privy"
End If

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
How can i extract the correct leave time on this code?
Replies
1
Views
558
rlv01
R
S
  • Question Question
VBA code - Override Cells of hard-entered data, based on VLookup results from hard data?
Replies
5
Views
1K
SuperCarter
S
A
  • Question Question
Run Time Error 53 Code
Replies
0
Views
2K
aknox6
A
C
  • Question Question
Macro takes forever to run formulas
Replies
3
Views
712
mperrah
M
E
  • Question Question
VBA vlookup code help
Replies
1
Views
334
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,613
Messages
6,179,896
Members
452,948
Latest member
Dupuhini

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