Auto Filter is slowing the macro

[walid66]

I have a macro that works fine and but the only problem is that the autofilter is slowing the down the macro. Is there another way of doing the autofilter to make the marco faster? The macro is attched.

[JBeaucaire]

I think the problem is the "activating", since most of your commands were addressing sheets directly, I corrected the few that weren't and removed all the selecting, this should run noticably faster.

Sub SortTwoWayNeigbors()

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim ws4 As Worksheet, ws5 As Worksheet, ws6 As Worksheet
Dim i As Long, j As Long, LR1 As Long, LR2 As Long
Dim A As String
Application.ScreenUpdating = False

Set ws1 = Sheets("Tow_Way_Neighbors")
'Set ws2 = Sheets("Process_Data")
Set ws3 = Sheets("Intra_Relations")
Set ws4 = Sheets("UtranRelation")
Set ws5 = Sheets("Run_Tool")
ws4.Cells(1, 1) = "UtranCell"
On Error Resume Next

j = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row

For s = j To 2 Step -1
    i = ws3.Cells(s, ws3.Columns.Count).End(xlToLeft).Column

    For m = 3 To i Step 1
        UtranCellUMTS = ws3.Cells(s, m).Text
        LR2 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
        With ws4    'ws4.Activate
            .AutoFilterMode = False
            .Range("A:A").AutoFilter
            LR3 = .Cells(.Rows.Count, "A").End(xlUp).Row
            With .Range(.Cells(2, 1), .Cells(LR3, 1))
                Set c = .Find(UtranCellUMTS, LookIn:=xlValues)
                If Not c Is Nothing Then
                    .Range("A:A").AutoFilter Field:=1, Criteria1:="=" & UtranCellUMTS & "*"
                    .Range("A2:A" & LR3).EntireRow.Copy
                    With ws1.Cells((LR2 + 1), 1)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
                Else
                    ws3.Cells(s, m).Interior.ColorIndex = 3
                    GoTo line1
                End If
            End With
        End With

'''''''''''''''''''''''''''Finding the Two Way Neighbors'''''''''''''''''''''

        On Error Resume Next
        varLU = ws3.Cells(s, 2)
        With ws1
            l = .Cells(.Rows.Count, "A").End(xlUp).Row
            With .Range(.Cells(2, 1), .Cells(l, 2))
                On Error Resume Next
                Set c = .Find(varLU, LookIn:=xlValues)
                If Not c Is Nothing Then
                    VarLU2 = c
                    If varLU = VarLU2 Then
                        RowNo = c.Row
                        ws3.Cells(s, m).Interior.ColorIndex = 6
                    End If
                Else
                    ws3.Cells(s, m).Interior.ColorIndex = 3
                End If
            End With
        
            .Cells.Clear
        End With
line1:
    Next m
Next s

ws4.AutoFilterMode = False
End Sub

[walid66]

Thanks for your help it worked perfectly. I really appreciated.