Optimising Vba code

[sowmyag]

My excel sheet is large with 250K rows and 32 columns, and the below code takes half an hour to complete.

Is it possible to optimise the below code and to run macro faster?

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Dim oCell As Range
    Dim oCell1 As Range
    Dim oCell2 As Range
    Dim oCell3 As Range
    Dim oCell4 As Range
    Dim oCell5 As Range
    Dim oCell6 As Range
    Dim oCell7 As Range
    'Set wb = GetObject("Q:\Dept\401k\Invoicing\forfeitures.xls")
    
    Dim i As Long
    i = 1
    
    Set ws1 = ThisWorkbook.Sheets("Matches")
    Set ws2 = ThisWorkbook.Sheets("LE50k")
    Set ws3 = ThisWorkbook.Sheets("Transit")
    Set ws4 = ThisWorkbook.Sheets("Transitclassfn_80k")
    
    Do While ws1.Cells(i, 12).Value <> ""
        Set oCell = ws2.Range("A:A").Find(What:=ws1.Cells(i, 20))
        If Not oCell Is Nothing Then ws1.Cells(i, 1) = oCell.Offset(0, 15)
        
        Set oCell1 = ws2.Range("A:A").Find(What:=ws1.Cells(i, 18))
        If Not oCell1 Is Nothing Then ws1.Cells(i, 2) = oCell1.Offset(0, 15)
        
        Set oCell2 = ws3.Range("b:b").Find(What:=ws1.Cells(i, 20))
        If Not oCell2 Is Nothing Then ws1.Cells(i, 3) = oCell2.Offset(0, 2)
        
        Set oCell3 = ws3.Range("b:b").Find(What:=ws1.Cells(i, 18))
        If Not oCell3 Is Nothing Then ws1.Cells(i, 4) = oCell3.Offset(0, 2)
        
        Set oCell4 = ws4.Range("b:b").Find(What:=ws1.Cells(i, 20))
        If Not oCell4 Is Nothing Then ws1.Cells(i, 5) = oCell4.Offset(0, 4)
        
        Set oCell5 = ws4.Range("b:b").Find(What:=ws1.Cells(i, 18))
        If Not oCell5 Is Nothing Then ws1.Cells(i, 6) = oCell5.Offset(0, 4)
        
        
        Set oCell6 = ws4.Range("b:b").Find(What:=ws1.Cells(i, 20))
        If Not oCell6 Is Nothing Then ws1.Cells(i, 7) = oCell6.Offset(0, -1)
        
        Set oCell7 = ws4.Range("b:b").Find(What:=ws1.Cells(i, 18))
        If Not oCell7 Is Nothing Then ws1.Cells(i, 8) = oCell7.Offset(0, -1)
        
        On Error Resume Next
        
        i = i + 1
        
    Loop
    
    'Set wb = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set ws3 = Nothing
    Set ws4 = Nothing


    Application.ScreenUpdating = True
    Application.EnableEvents = True

Thanks

 

[Rick Rothstein]

Instead of making us try and figure out what your data looks like, what the code is trying to do with it and what the output is supposed to look like, why not provide a small representative sample of your existing data, what the output for that data should look like and a description of what the code is doing to achieve that output.

 

[sowmyag]

The workbook has 5 worksheets and I am trying to lookup the values from three different worksheets like "LE50K" ," Transit" to the worksheet "Matches". Instead of using index match formula,I have used do while loop to lookup values.

Eg: A 2 of Matches = index(column T of LE50k ,match( p2 of matches, column a of LE 50k))

I repeat the same logic for 7 columns from three worksheets to Matches worksheet.

Hope this helps