Sub Taking too Long to Complete

[farhan11941234]

There are 9,000 Rows in my Data, this sub is taking too long.if there is any other way to do the same with VBA

Sub combinedata()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lc As Long
Dim bilastrow As Long
Dim x, y As Long
s4lastrow = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
s3lastrow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row



For x = 2 To s4lastrow
    
        For y = 2 To s3lastrow
        
            If Sheet4.Cells(x, 1).Value = Sheet3.Cells(y, 1).Value Then
            Sheet4.Cells(x, 8).Value = Sheet3.Cells(y, 5).Value
            Sheet4.Cells(x, 9).Value = Sheet3.Cells(y, 2).Value
            Sheet4.Cells(x, 10).Value = Sheet3.Cells(y, 3).Value
            Sheet4.Cells(x, 11).Value = Sheet3.Cells(y, 4).Value
            Sheet4.Cells(x, 12).Value = Sheet3.Cells(y, 6).Value
        
            End If
        Next y
Next x
        
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[RoryA]

Untested, but try this:

Sub combinedata()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim s3lastrow As Long, s4LastRow As Long
s4LastRow = sheet4.Cells(Rows.Count, 1).End(xlUp).Row
s3lastrow = sheet3.Cells(Rows.Count, 1).End(xlUp).Row
Dim s4ColAData, s4Output, s3Data
s4ColAData = sheet4.Range("A2:A" & s4LastRow).Value
s4Output = sheet4.Range("H2:L" & s4LastRow).Value
s3Data = sheet3.Range("A1:F" & s3lastrow).Value
Dim x As Long
For x = 1 To UBound(s4ColAData)
   Dim match
   match = Application.match(s4ColAData(x, 1), sheet3.Range("A:A"), 0)
   If Not IsError(match) Then
      s4Output(x, 1) = s3Data(match, 5)
      s4Output(x, 2) = s3Data(match, 2)
      s4Output(x, 3) = s3Data(match, 3)
      s4Output(x, 4) = s3Data(match, 4)
      s4Output(x, 5) = s3Data(match, 6)
   End If
Next x
sheet4.Range("H2:L" & s4LastRow).Value = s4Output
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub