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

 

[DanteAmor]

Try this code, it should be faster (uses matrices for both sheets):

Sub FindCopyReplaceAbove_v2()
  Dim a    As Variant, b As Variant, c As Variant
  Dim n    As Long, i As Long, j As Long, k As Long
  Dim dic  As Object
  Dim rng  As Range
  Dim sh1  As Worksheet
  
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  c = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row).Value
  For i = 1 To UBound(c, 1)
    dic(c(i, 1)) = c(i, 2) & "|" & c(i, 3)
  Next
  
  a = sh1.Range("A2:AY" & sh1.Range("AE" & Rows.Count).End(xlUp).Row).Value
  Set rng = sh1.Range("A1")
  
  ReDim b(1 To UBound(a, 1) * 2, 1 To UBound(a, 2))
  For i = 1 To UBound(a, 1)
    k = k + 1
    If dic.exists(a(i, 31)) Then
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
        b(k + 1, j) = a(i, j)
        If j = 31 Then b(k + 1, j) = Split(dic(a(i, 31)), "|")(0)
        If j = 32 Then b(k + 1, j) = Split(dic(a(i, 31)), "|")(1)
        Set rng = Union(rng, sh1.Range("A" & k + 1).Resize(2))
      Next
      k = k + 1
    Else
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
  
  sh1.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  rng.EntireRow.Interior.ColorIndex = 35
  sh1.Rows(1).Interior.ColorIndex = xlNone
End Sub

 

[DanteAmor]

so is this for the copy above or below?

Sorry, I didn't understand that you have 2 codes
- FindCopyReplaceBelow
- FindCopyReplaceAbove

So the change between one code and the other code is minimal.
I propose you create a single code for both processes.
In this way we standardize the codes and if in the future you need any changes, you would only modify one code.

For Below run this code:

Sub FindCopyReplaceBelow()
  Call FindCopyReplace("Below")
End Sub

For Above run this code:

Sub FindCopyReplaceAbove()
  Call FindCopyReplace("Above")
End Sub

The previous codes will execute a procedure and send it a parameter to know if it is below or above.

Put in the same module the 3 codes. The following code is what will copy the records:

Sub FindCopyReplace(isWhere As String)
  Dim a    As Variant, b As Variant, c As Variant
  Dim n    As Long, i As Long, j As Long, k As Long, m As Long
  Dim dic  As Object
  Dim rng  As Range
  Dim sh1  As Worksheet
  
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  c = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row).Value
  For i = 1 To UBound(c, 1)
    dic(c(i, 1)) = c(i, 2) & "|" & c(i, 3)
  Next
  
  a = sh1.Range("A2:AY" & sh1.Range("AE" & Rows.Count).End(xlUp).Row).Value
  Set rng = sh1.Range("A1")
  
  ReDim b(1 To UBound(a, 1) * 2, 1 To UBound(a, 2))
  For i = 1 To UBound(a, 1)
    k = k + 1
    If dic.exists(a(i, 31)) Then
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
        b(k + 1, j) = a(i, j)   'copy record
        
        If isWhere = "Below" Then m = k + 1 Else m = k
        If j = 31 Then b(m, j) = Split(dic(a(i, 31)), "|")(0)
        If j = 32 Then b(m, j) = Split(dic(a(i, 31)), "|")(1)
        Set rng = Union(rng, sh1.Range("A" & k + 1).Resize(2))
        
      Next
      k = k + 1
    Else
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
  
  sh1.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  rng.EntireRow.Interior.ColorIndex = 35
  sh1.Rows(1).Interior.ColorIndex = xlNone
End Sub

 

[Dazzawm]

Sorry, I didn't understand that you have 2 codes
- FindCopyReplaceBelow
- FindCopyReplaceAbove

So the change between one code and the other code is minimal.
I propose you create a single code for both processes.
In this way we standardize the codes and if in the future you need any changes, you would only modify one code.

For Below run this code:

Sub FindCopyReplaceBelow()
  Call FindCopyReplace("Below")
End Sub

For Above run this code:

Sub FindCopyReplaceAbove()
  Call FindCopyReplace("Above")
End Sub

The previous codes will execute a procedure and send it a parameter to know if it is below or above.

Put in the same module the 3 codes. The following code is what will copy the records:

Sub FindCopyReplace(isWhere As String)
  Dim a    As Variant, b As Variant, c As Variant
  Dim n    As Long, i As Long, j As Long, k As Long, m As Long
  Dim dic  As Object
  Dim rng  As Range
  Dim sh1  As Worksheet
 
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  c = Sheets("Sheet2").Range("A1:C" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row).Value
  For i = 1 To UBound(c, 1)
    dic(c(i, 1)) = c(i, 2) & "|" & c(i, 3)
  Next
 
  a = sh1.Range("A2:AY" & sh1.Range("AE" & Rows.Count).End(xlUp).Row).Value
  Set rng = sh1.Range("A1")
 
  ReDim b(1 To UBound(a, 1) * 2, 1 To UBound(a, 2))
  For i = 1 To UBound(a, 1)
    k = k + 1
    If dic.exists(a(i, 31)) Then
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
        b(k + 1, j) = a(i, j)   'copy record
       
        If isWhere = "Below" Then m = k + 1 Else m = k
        If j = 31 Then b(m, j) = Split(dic(a(i, 31)), "|")(0)
        If j = 32 Then b(m, j) = Split(dic(a(i, 31)), "|")(1)
        Set rng = Union(rng, sh1.Range("A" & k + 1).Resize(2))
       
      Next
      k = k + 1
    Else
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
 
  sh1.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  rng.EntireRow.Interior.ColorIndex = 35
  sh1.Rows(1).Interior.ColorIndex = xlNone
End Sub

Thank you so much, works perfect and so quick too.

 

[DanteAmor]

Im glad to help you.
Thanks for the feed back.

 

[Dazzawm]

Don't worry, if you post in the same thread where I responded, an alert appears for me.
View attachment 121757


Also in the threads that I have participated in it appears in bold:
View attachment 121758

Then it's very safe to know that you posted something new in one of my threads.

If you publish a new thread and I have the opportunity to review it, I will gladly do so.

Thanks