How to loop faster?

[BRB1983]

i have a code when on cell change then loop and fine matching value. then offset and paste in cell to left.
code works fine but need it to work faster. Any help would be appreciated.

Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Sheet1.Range("C2:C50")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
      
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim ws As Worksheet, ws2 As Worksheet
    Set ws = Sheet1
    Set ws2 = Sheet2
    For i = 2 To 5000
        If IsEmpty(ws.Range("C" & i)) Then
            Exit For
        End If
    For j = 2 To 5000
        If IsEmpty(ws2.Range("E" & j)) Then
            Exit For
        End If
If ws.Range("C" & i).Text = ws2.Range("E" & j).Text Then
    If ws.Range("B" & i).Value = "" Then
        ws.Range("B" & i).Value = ws2.Range("E" & j).Value & "-" & ws2.Range("B" & j).Value
    Exit For
End If
    End If
    Next j
    Next i
End If

End Sub

 

[MPW]

I noticed that you did not close the loops with a next. Also I think one loop would be enough to do both functions

For i = 2 To 5000
        If IsEmpty(ws.Range("C" & i)) Then
            Exit For
        End If
        If IsEmpty(ws2.Range("E" & i)) Then
            Exit For
        End If
Next i

Unless I am missing something, this should help.

 

[offthelip]

try using variant arrays instead of referencing the worksheet multiple times in a loop.
this code in untested but should show you how to do it ans will be much faster:

Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Sheet1.Range("C2:C50")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
     
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim ws As Worksheet, ws2 As Worksheet
    Set ws = Sheet1
    Set ws2 = Sheet2
    wsr = ws.Range(Cells(1, 3), Cells(5000, 3))
    wsr2 = ws.Range(Cells(1, 5), Cells(5000, 5))
   
    For i = 2 To 5000
        If (wsr(i, 1))="" Then
            Exit For
        End If
    For j = 2 To 5000
        If (wsr2(j, 1))="" Then
            Exit For
        End If
If wsr(i, 1) = wsr2(i, 1) Then
    If ws.Range("B" & i).Value = "" Then
        ws.Range("B" & i).Value = wsr(j, 1) & "-" & wsr2(j, 1)
    Exit For
End If
    End If
    Next j
    Next i
End If

End Sub

 

[BRB1983]

should the wsr be dim as range?
Dim wsr as range
Dim wsr2 as range

 

[BRB1983]

im getting varible not defined

 

[Fluff]

They need to be declared as Variant
Also why are you looping through 5000 cells on both sheets, when the code will only be triggered if you change C2:C50?

 

[BRB1983]

They need to be declared as Variant
Also why are you looping through 5000 cells on both sheets, when the code will only be triggered if you change C2:C50?

sheet 2 needs to be at 5000 but sheet 1 will not exceed 50

 

[Fluff]

In that case for the first loop you can change this For i = 2 To 5000 to For i = 2 To 50 for both codes, which will speed it up

 

[BRB1983]

ok, i tried the code that you provided and im getting no results and no errors.

 

[Fluff]

I didn't provide it, that was offthelip