Loop Working but gives me a run Time Error 1004

[jalrs]

Hello guys,

As title says, I'm getting a run time error 1004 even tho my loop is working as intended. I can't find any solution to stop this, so hopefully here. Error as attachment, vba code follows:

Sub myloopattempt()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, i As Long
Dim mypath As String, docname As String, valorfiltro As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Stock")
Set ws2 = wb1.Worksheets("MACRO 1")

lr1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

ws2.Activate

    For i = 2 To lr1
        
        valorfiltro = Cells(i, 1).Value
        
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Temp\ST_TEMPLATE_" & Cells(i, 1).Value & ".xlsx"
        
        Set wb2 = Workbooks("ST_TEMPLATE_" & valorfiltro & ".xlsx")
        
        Set ws3 = wb2.Worksheets("Pendentes")
        
        ws3.Activate
        
        ws3.UsedRange.Offset(1).ClearContents
        
        lr3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
        
        ws1.Activate
        
        With ws1.Range("A5:AV" & lr1)
        
            .AutoFilter 46, valorfiltro
            .AutoFilter 47, "Em tratamento"
            
            With ws1
        
            .Range("A6:AV" & lr1).Copy ws3.Cells(2, 1)
            .Range("BH6:BH" & lr1).Copy ws3.Cells(2, 49)
            
            End With
            
            .AutoFilter
        
        End With
        
        lr3 = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
        ws3.Range("A" & lr3 & ":A1001").EntireRow.Delete
        
        wb2.Activate
        
        ws3.Activate
        
        lr4 = Cells(Rows.Count, "AT").End(xlUp).Row
        
        If lr4 > 1 Then
        
            Range("AY2:AY" & lr4).FormulaR1C1 = _
            "=IF(RC[-1]="""","""",VLOOKUP(RC[-1],TAB_FDB!C[-50]:C[-49],2,0))"
            
        End If
        
        ws3.Protect Password:="blabla", _
        DrawingObjects:=True, _
        Contents:=True, _
        Scenarios:=True, _
        UserInterfaceOnly:=True, _
        AllowFormattingCells:=False, _
        AllowFormattingColumns:=False, _
        AllowFormattingRows:=False, _
        AllowInsertingColumns:=False, _
        AllowInsertingRows:=False, _
        AllowInsertingHyperlinks:=False, _
        AllowDeletingColumns:=False, _
        AllowDeletingRows:=False, _
        AllowSorting:=True, _
        AllowFiltering:=False, _
        AllowUsingPivotTables:=False

        mypath = ThisWorkbook.Path & "\Anexos\"
            
        wb1.Activate
        
        ws2.Activate
        
        docname = Cells(i, 5).Value
        
        wb2.Activate
        
        ws3.Activate
        
        ActiveWorkbook.SaveAs Filename:=mypath & docname & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
        ActiveWorkbook.Close
        
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Any help is appreciated

 

[jalrs]

The loop works until lr1. I think it should be lr2...?

Thank you so much! Under my nose and I couldn't see it, Don't even know how to feel.

Thanks Takae, marked as solution!