Hi

Does anyone know what I am doing wrong - macro takes an excessive amt of time to run ?XL_Export.xlsb

I include the file required to make it run through

Thanks



Option Explicit
Dim Filesavename As String
Dim WeeklyFN As String
Dim MainFN As String
Dim MFile As String
Dim lrow As Long
Dim sfield As String
Dim cellcol As Long
Dim i As Long
Dim lastrow As Long
Dim rownumber As Long
Dim c As Object
Dim ws As Worksheet
Dim ws3 As Worksheet
Dim ws2 As Worksheet
Dim rcell As Range
Dim ws4 As Worksheet





Sub PaulHSS()


Application.DisplayAlerts = False
MFile = ActiveWorkbook.Name
Application.ScreenUpdating = False

WeeklyFN = Application.GetOpenFilename(fileFilter:="All files (*.*), *.*", Title:="Paul HSS - Please open weekly stock report")
If WeeklyFN = "False" Or WeeklyFN = "" Then
    MsgBox "You have not selected a file."
    Exit Sub
Else
   Workbooks.Open Filename:=WeeklyFN
    WeeklyFN = ActiveWorkbook.Name
    'MsgBox "You selected " & WeeklyFN, Title:="Paul HSS - File Selected"
End If

Range("B:B").NumberFormat = "@"

Cells.Select
    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Add Key:=Range("B2:B5000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Table1").Sort
        .SetRange Range("A1:E5000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    Windows("Resale Ordering.xlsm").Activate
    Sheet2.Activate
    With Sheets(2)
    .UsedRange.ClearContents
    .Columns(1).NumberFormat = "@"
    .[a1:g1].Value = Array("unit_no", "stock_code", "stock_name", "stockstatus_name", "minimum holding", "current stock", "variance")
    End With
    Range("A2").Select
    
   
Set ws = Workbooks("XL_Export.xlsb").Sheets("Table1")
Set ws3 = Workbooks("Resale Ordering.xlsm").Sheets("Minimum Stock Holding")
Set ws2 = Workbooks("Resale Ordering.xlsm").Sheets("All Stock Variances")
Set ws4 = Workbooks("Resale Ordering.xlsm").Sheets("Negative Variances")

ws3.Activate
Columns("F:G").Insert
With Range("F2:F" & ws3.Range("B" & Rows.Count).End(3)(1).Row)
    .Formula = "=iferror(VLOOKUP(B2,[XL_Export.xlsb]Table1!$B$2:$E$" & ws.UsedRange.Rows.Count & ",4,FALSE),0)"
    .Value = .Value
End With
With Range("G2:G" & ActiveSheet.UsedRange.Rows.Count)
    .Formula = "=F2-E2"
    .Value = .Value
End With
For Each rcell In ws3.Range("G2:G" & ws3.Range("B" & Rows.Count).End(3)(1).Row)
    'If rcell.Value >= 1 Then
       ' GoTo zz
   ' Else
       Range(rcell.Offset(, -6), rcell.Offset(, -3)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
       Range(rcell.Offset(, -2), rcell.Offset(, -1)).Copy ws2.Range("E" & Rows.Count).End(3)(2)
       rcell.Copy ws2.Range("G" & Rows.Count).End(3)(2)
    'End If
'zz:
Next rcell
Columns("F:G").Delete

'ws4.Activate

    With Sheets(4)
    .UsedRange.ClearContents
    .Columns(1).NumberFormat = "@"
    .[a1:g1].Value = Array("unit_no", "stock_code", "stock_name", "stockstatus_name", "minimum holding", "current stock", "variance")
    End With
    Range("A2").Select

'Columns("F:G").Insert
With Range("F2:F" & ws3.Range("B" & Rows.Count).End(3)(1).Row)
    .Formula = "=iferror(VLOOKUP(B2,[XL_Export.xlsb]Table1!$B$2:$E$" & ws.UsedRange.Rows.Count & ",4,FALSE),0)"
    .Value = .Value
End With
With Range("G2:G" & ActiveSheet.UsedRange.Rows.Count)
    .Formula = "=F2-E2"
    .Value = .Value
End With
For Each rcell In ws3.Range("G2:G" & ws3.Range("B" & Rows.Count).End(3)(1).Row)
    If rcell.Value >= 0 Then
        GoTo zz
   Else
       Range(rcell.Offset(, -6), rcell.Offset(, -3)).Copy ws4.Range("A" & Rows.Count).End(3)(2)
       Range(rcell.Offset(, -2), rcell.Offset(, -1)).Copy ws4.Range("E" & Rows.Count).End(3)(2)
       rcell.Copy ws4.Range("G" & Rows.Count).End(3)(2)
    End If
zz:
Next rcell
Columns("F:G").Delete

ws2.Activate
Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("G:G").Select
    Selection.NumberFormat = "0_ ;[Red]-0 "
    Range("A2").Select
    Sheet2.Select
    Range("a1").Select
    Columns("A").Delete
    Columns("C").Delete
    
Sheet4.Select
Cells.Select
   Cells.EntireColumn.AutoFit
   Columns("G:G").Select
   Selection.NumberFormat = "0_ ;[Red]-0 "
    Range("a1").Select
    Columns("A").Delete
    Columns("C").Delete
    Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
    
Application.ScreenUpdating = True
End Sub