Error In Code

[Dazzawm]

I have a code that basically looks for data in column A on sheet 2, in column AE on sheet 1. When that number is found it copies and inserts the entire row above and changes what is in column A to what's in column B on sheet 2 into the copied and inserted row in AE on sheet 1.

All of a sudden I am getting this error on some files. Any ideas please?

Sub FindCopyReplaceAbove()

Application.EnableEvents = False
Application.Calculation = xlCalculationManual = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rng1    As Range
Dim Dn1     As Range
Dim rng2    As Range
Dim Dn2     As Range
Dim n       As Long
With Sheets("Sheet2")
    Set rng2 = .Range(.Range("A1"), .Range("A" & Rows.count).End(xlUp))
End With
For Each Dn2 In rng2
With Sheets("Sheet1")
    Set rng1 = .Range(.Range("AE2"), .Range("AE" & Rows.count).End(xlUp))
        For n = rng1.count + 1 To 2 Step -1
            With .Range("AE" & n)
            If .Value = Dn2 Then
                .EntireRow.Interior.ColorIndex = 35
                .EntireRow.Copy
                .EntireRow.Insert Shift:=xlUp
                .Offset(-1).Resize(, 2).Value = Dn2.Offset(, 1).Resize(, 2).Value
            End If
            End With
            Next n
   End With
 Next Dn2
 
Application.EnableEvents = True
Application.Calculation = xlCalculationManual = True
Application.ScreenUpdating = True

End Sub

 

[Dazzawm]

What is the address of Dn1 when you try to insert, offset by 1 row and shift down

Sorry don't understand

 

[MARK858]

What cell address is Dn1 when the code errors in the line below

Dn1.Offset(1).EntireRow.Insert Shift:=xlDown

 

[Dazzawm]

What cell address is Dn1 when the code errors in the line below

Dn1.Offset(1).EntireRow.Insert Shift:=xlDown

It doesn't error as such with a yellow line, just brings up the photoed error after a few seconds.

 

[MARK858]

Put a Debug.Print Dn1.Address line at the start of the loop and post the last address that prints in the immediate window when the code errors

For Each Dn1 In rng1
Debug.Print Dn1.Address
            If Dn1 = Dn2 Then

 

[Dazzawm]

Put a Debug.Print Dn1.Address line at the start of the loop and post the last address that prints in the immediate window when the code errors

For Each Dn1 In rng1
Debug.Print Dn1.Address
            If Dn1 = Dn2 Then

Typical! I run it then on said file and it completed. I will have to post next time it happens. Watch this space.

 

[DanteAmor]

No formulas on sheet 1. Columns up to and including A to AY. Macro works well on majority of files and depends on amount of data on sheet 2.

Try this change as I do something else with matrices for both sheets.

Sub FindCopyReplaceAbove()
  Dim rng1    As Range, Dn1     As Range
  Dim rng2    As Range, Dn2     As Range
  Dim n       As Long
  Dim dic     As Object
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual = False
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet2")
    Set rng2 = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
  End With
  For Each Dn2 In rng2
    dic(Dn2.Value) = Dn2.Row
  Next
  
  With Sheets("Sheet1")
    Set rng1 = .Range(.Range("AE2"), .Range("AE" & Rows.Count).End(xlUp))
    For n = rng1.Count + 1 To 2 Step -1
      With .Range("AE" & n)
        If dic.exists(.Value) Then
          .EntireRow.Interior.ColorIndex = 35
          .EntireRow.Copy
          .EntireRow.Insert Shift:=xlUp
          .Offset(-1).Resize(, 2).Value = Sheets("Sheet2").Range("A" & dic(.Value)).Offset(, 1).Resize(, 2).Value
        End If
      End With
    Next n
  End With
   
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

 

[Dazzawm]

Try this change as I do something else with matrices for both sheets.

Sub FindCopyReplaceAbove()
  Dim rng1    As Range, Dn1     As Range
  Dim rng2    As Range, Dn2     As Range
  Dim n       As Long
  Dim dic     As Object
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual = False
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  With Sheets("Sheet2")
    Set rng2 = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
  End With
  For Each Dn2 In rng2
    dic(Dn2.Value) = Dn2.Row
  Next
 
  With Sheets("Sheet1")
    Set rng1 = .Range(.Range("AE2"), .Range("AE" & Rows.Count).End(xlUp))
    For n = rng1.Count + 1 To 2 Step -1
      With .Range("AE" & n)
        If dic.exists(.Value) Then
          .EntireRow.Interior.ColorIndex = 35
          .EntireRow.Copy
          .EntireRow.Insert Shift:=xlUp
          .Offset(-1).Resize(, 2).Value = Sheets("Sheet2").Range("A" & dic(.Value)).Offset(, 1).Resize(, 2).Value
        End If
      End With
    Next n
  End With
  
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Thanks, so is this for the copy above or below?

 

[Dazzawm]

Sorry for my bad. I was having the error on the copy below with the code in post 7.

 

[DanteAmor]

Try this code, it's about your new code from post #7

Sub FindCopyReplaceAbove()
  Dim rng1    As Range, Dn1     As Range
  Dim rng2    As Range, Dn2     As Range
  Dim n       As Long
  Dim dic     As Object
  
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual = False
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet2")
    Set rng2 = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
  End With
  For Each Dn2 In rng2
    dic(Dn2.Value) = Dn2.Row
  Next
  
  With Sheets("Sheet1")
    Set rng1 = .Range(.Range("AE2"), .Range("AE" & Rows.Count).End(xlUp))
  End With
  For Each Dn1 In rng1
    If dic.exists(Dn1.Value) Then
      Dn1.EntireRow.Interior.ColorIndex = 35
      Dn1.EntireRow.Copy
      Dn1.Offset(1).EntireRow.Insert Shift:=xlDown
      Dn1.Offset(1).Resize(, 2).Value = Sheets("Sheet2").Range("A" & dic(Dn1.Value)).Offset(, 1).Resize(, 2).Value
    End If
  Next Dn1
  
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

 

[Dazzawm]

Thank you @DanteAmor and @MARK858 I will let you both know how I get on and if the error happens again.