reproduce code to make fast ,currently too slow and crash

[Hasson]

Hi
I have this code

Sub Macro1()


  Dim i, S As Integer
  Dim Sht, tblPartsAs worksheet
  

  Set tblParts = ActiveWorkbook.Sheets("ws")
  Set Sht = ActiveWorkbook.Sheets("sh")
LR = tblParts.Range("E" & Rows.Count).End(3)
LR1 = Sht.Range("E" & Rows.Count).End(3)
  For i = 2 To LR
  For S = 2 To LR1
   If tblParts.Range("B" & i).Value = Sht.Range("B" & S).Value And Sht.Range("F" & S).Value > 0 Then
   Sht.Range("F" & S).Value = 0

    End If
  Next
  Next

End Sub

the code will match column B between two sheets , if the ID is matched in SH sheet and the column F contains numeric values then will should show zero in column F for SH sheet when the ID in column B is the same thing when compare with ws sheet.
the cod is too slow to running !!!
any help ,please?

 

[Jeffrey Mahoney]

Please try this. I don't have a way to test on my end without your workbook

Sub Macro1()


  Dim i, S As Integer
  Dim Sht As Worksheet, tblParts As Worksheet
  Dim LR As Long
  Dim LR1 As Long
  Dim u As Range
  
  Application.Calculation = xlCalculationManual
  
  Set tblParts = ActiveWorkbook.Sheets("ws")
  Set Sht = ActiveWorkbook.Sheets("sh")
  LR = tblParts.Range("E" & Rows.Count).End(3)
  LR1 = Sht.Range("E" & Rows.Count).End(3)
  For i = 2 To LR
    For S = 2 To LR1
      If tblParts.Range("B" & i).Value = Sht.Range("B" & S).Value And Sht.Range("F" & S).Value > 0 Then
        If Not u Is Nothing Then
          Set u = Union(u, Sht.Range("F" & S))
        Else
          Set u = Sht.Range("F" & S)
        End If
      End If
    Next
  Next
  If Not u Is Nothing Then
    u.Value = 0
  End If
  
  Application.Calculation = xlCalculationAutomatic

End Sub

 

[Peter_SSs]

I have this code

Are you sure that is your code?
Please check your Dim statements and your code lines that calculate LR and LR1

Also note that Dim i, S As Integer only declares S as Integer and not i. i will be a Variant.
Same issue with the worksheet declaration line once you fix the missing space character.

 

[Peter_SSs]

Taking something of a guess about what you are trying to do with the code, give this a try with a copy of your workbook to see if it does what you want and to test for speed.

Sub Macro1_v2()
  Dim i As Long, S As Long, LR As Long, LR1 As Long
  Dim Sht As Worksheet, tblParts As Worksheet
  Dim BSht As Variant, FSht As Variant, BtblParts As Variant
  
  Set tblParts = ActiveWorkbook.Sheets("ws")
  Set Sht = ActiveWorkbook.Sheets("sh")
  LR = tblParts.Range("E" & Rows.Count).End(3).Row
  LR1 = Sht.Range("E" & Rows.Count).End(3).Row
  BtblParts = Application.Index(tblParts.Cells, Evaluate("Row(2:" & LR & ")"), 2)
  With Sht
    BSht = Application.Index(.Cells, Evaluate("Row(2:" & LR1 & ")"), 2)
    FSht = Application.Index(.Cells, Evaluate("Row(2:" & LR1 & ")"), 6)
    For i = 1 To UBound(BtblParts)
      For S = 1 To UBound(BSht)
        If BtblParts(i, 1) = BSht(S, 1) And FSht(S, 1) > 0 Then FSht(S, 1) = 0
      Next S
    Next i
    .Range("F2").Resize(UBound(FSht)).Value = FSht
  End With
End Sub

 

[Hasson]

Thank Jeffery , but unfortunately still too slow !

 

[Hasson]

Hi Peter,
well, I read your comment and thanks for your clarification .
as to your code is really fast .
thank you so much.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

BTW, this would be slightly faster again, though I don't know whether you would notice the difference without measuring.

Sub Macro1_v3()
  Dim i As Long, S As Long, LR As Long, LR1 As Long
  Dim Sht As Worksheet, tblParts As Worksheet
  Dim BSht As Variant, FSht As Variant, BtblParts As Variant
  
  Set tblParts = ActiveWorkbook.Sheets("ws")
  Set Sht = ActiveWorkbook.Sheets("sh")
  LR = tblParts.Range("E" & Rows.Count).End(3).Row
  LR1 = Sht.Range("E" & Rows.Count).End(3).Row
  BtblParts = Application.Index(tblParts.Cells, Evaluate("Row(2:" & LR & ")"), 2)
  With Sht
    BSht = Application.Index(.Cells, Evaluate("Row(2:" & LR1 & ")"), 2)
    FSht = Application.Index(.Cells, Evaluate("Row(2:" & LR1 & ")"), 6)
    For S = 1 To UBound(BSht)
      For i = 1 To UBound(BtblParts)
        If BtblParts(i, 1) = BSht(S, 1) And FSht(S, 1) > 0 Then
          FSht(S, 1) = 0
          Exit For
        End If
      Next i
    Next S
    .Range("F2").Resize(UBound(FSht)).Value = FSht
  End With
End Sub