Write a more efficient code

Hi Karl,

Not all of your code is included in the sample

It looks as though you can do some block deletions:

'Call XDeleteData1Rows(Range1End)
    Worksheets("Data input").Rows("1:" & Range1End).EntireRow.Delete

Well, so far, just the block deletions for these two deletion routines:

'Call XDeleteData1Rows(Range1End)
    Worksheets("Data input").Rows("1:" & Range1End).EntireRow.Delete

AND

'Call XDeleteData2Rows(LR)
    Worksheets("Data input").Rows("1:" & LR).EntireRow.Delete

Add this copy routine code change:

Sub XCopyData1(ByRef Times)

Dim LC As Long
Dim LR As Long
Dim LR2 As Long

    LC = Sheets("Data output").Cells(1, Columns.Count).End(xlToLeft).Column
        
    LR = Worksheets("Data output").Range("A" & Rows.Count).End(xlUp).Row
        
    Worksheets("Data output").Range("A" & LR).Resize(Times, LC).Value = _
    Worksheets("Data output").Range("A" & LR).Resize(1, LC).Value
    
    
End Sub

*Sample took 3.4s at start now down to 1.2s

I'm sorry too - I edited the last post with an observation. I'll be looking at your code off and on for maybe another hour

The first thing I would do would be to delete all the blank data rows.

I will create a code snippet for you to try.

Sub Macro1()

Optimise (True)

LR = Cells(Rows.Count, 1).End(xlUp).Row
    Range("I1:I" & LR).FormulaR1C1 = _
        "=IF(CONCAT(RC[-8]:RC[-1])=REPT(""@NA"",COLUMNS(RC[-8]:RC[-1])),0,1)"
    Range("I1:I" & LR).Value = Range("I1:I" & LR).Value
    Range("J1:J" & LR).FormulaR1C1 = "=ROW()"
    Range("J1:J" & LR).Value = Range("J1:J" & LR).Value

    ActiveWorkbook.Worksheets("Data input").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data input").Sort.SortFields.Add Key:=Range( _
        "I1:I" & LR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Data input").Sort.SortFields.Add Key:=Range( _
        "J1:J" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Data input").Sort
        .SetRange Range("A1:J" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
 Set P = Columns("I:I").Find(What:="0", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row
    Rows(P & ":" & LR).Delete Shift:=xlUp
    Columns("I:J").Delete Shift:=xlToLeft
    
Optimise (False)

End Sub

Sub Optimise(Flag As Boolean)
On Error Resume Next
F = Not Flag
Application.ScreenUpdating = F
Application.DisplayAlerts = F
Application.EnableEvents = F
Application.DisplayStatusBar = F
ActiveSheet.DisplayPageBreaks = F
If F = True Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
Changeflag = 0
On Error GoTo 0
End Sub

You're welcome!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.