Speeding Up Loop Code

[Celticfc]

Hi all,


Column A in Sheet 1 has 150 Employee ID’s and Column B has their salary.All I’m doing is pasting their salary to the Master sheet (which has 4000ID’s).
This process take about 1 minute to complete.
Is there a way to speed it up at all? I was wondering if the loop canstop once all 150 ID’s have been found? I.e. those 150 ID’s could be betweenrows 1-500 in Master Sheet so I don’t want it to check all the way to 4000rows?

Thank you very much in advance.

[COLOR=black][FONT=Calibri Light]Private Sub lookupandcopy[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]

[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]
Dim j As Long, i As Long
Dim sh_1, sh_3 As Worksheet
Dim MyName As String[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]

[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]
Set sh_1 = ThisWorkbook.Sheets("sheet1")
Set sh_3 = Workbooks("master.xlsb").Sheets("master")[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]For j = 1 To 150
MyName = sh_1.Cells(j, 1).Value[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]
[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]For i = 1 To 4000
    If sh_3.Cells(i, 1).Value = MyName Then
        sh_3.Cells(i, 2).Value = sh_1.Cells(j,2).Value
    End If[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]

[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]   Next i[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]
[/FONT][/COLOR][COLOR=black][FONT=Calibri Light] Next j[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]

[/FONT][/COLOR][COLOR=black][FONT=Calibri Light]
[/FONT][/COLOR][COLOR=#222222][FONT=Calibri Light]Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

[/FONT][/COLOR]

 

[Peter_SSs]

Yes ID in A, Salary in B and Position on S.

OK, thanks. Try this (not tested much)

Sub UpdateSalaries_v4()
  Dim a As Variant, ID As Variant
  Dim d1 As Object, d2 As Object
  Dim i As Long, lr As Long
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("Row(2:" & lr & ")"), Array(1, 2, 19))
  End With
  For i = 1 To UBound(a)
    If LCase(a(i, 3)) = "manager" Then
      If Len(a(i, 1)) > 0 And Len(a(i, 2)) > 0 Then d1(a(i, 1)) = a(i, 2)
    End If
  Next i
  With Sheets("Master")
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("Row(2:" & lr & ")"), Array(1, 2, 19))
    For i = 1 To UBound(a)
      If LCase(a(i, 3)) = "manager" Then d2(a(i, 1)) = i
    Next i
    For Each ID In d1.Keys()
      If d2.exists(ID) Then a(d2(ID), 2) = d1(ID)
    Next ID
    .Range("B2").Resize(UBound(a)).Value = Application.Index(a, 0, 2)
  End With
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub