Excel vba fast first time then slow

Question

Hi,

Really having issues copying data to another sheet, i have tried copy/paste, copy dest, value = value, array etc. i have also tried all the manual calculation, nodisplayalerts and all the other usual things. When running on a non shared workbook with others, it works perfect no issues can run as many times as you wanted instantly, soon i share the workbook with others, thats when the fun begins, usually the first time it will run fine and fairly quick, the second time onwards, i could go and make myself a cup of tea/coffee before it completes. the status bar shows filling cells and the turtle with a pencil comes out writing out the cells. i have spent the last week pulling my hair out and searching all over the web and cannot find anything.

I have tried creating a new sheet incase there was an issue with the old still the same, tried disabling track history, on the local HDD, on the network, original i was copying from another workbook, so i have tried in the same workbook, all the same. below is the latest code im trying, i dont fully understand it as not used arrays before, but seems to work no shared. i will eventually have this putting data on multiple sheets, on a for loop somehow, but at the moment i need to get it working on one sheet. What am i missing ? seems like its not closing of previous run.

Sub CopyDetails()       Windows("ArrayCopy1.xlsm").Activate     Dim rng As Range     Dim arrS1, arrD1     Dim lRow As Long     Dim i1 As Long, ct1 As Long        Dim wb As Workbook     Set wb = ThisWorkbook 'source workbook     Dim ws As Worksheet     Dim tws1 As Worksheet        Set ws = wb.Sheets("Data") 'source worksheet     Set tws1 = wb.Sheets("Sheet1") 'target worksheet        Date1 = Format("23/09/2023", "MM/DD/YYYY")        lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row        ct1 = 1        With ws         arrS1 = .Range("A2:G" & lRow)         ReDim arrD1(1 To UBound(arrS1), 1 To 7)         For i1 = 1 To UBound(arrS1)             If Format(arrS1(i1, 5), "MM/DD/YYYY") = Date1 Then                 arrD1(ct1, 1) = arrS1(i1, 1)                 arrD1(ct1, 2) = arrS1(i1, 2)                 arrD1(ct1, 3) = arrS1(i1, 3)                 arrD1(ct1, 4) = arrS1(i1, 4)                 arrD1(ct1, 5) = arrS1(i1, 5)                 arrD1(ct1, 6) = arrS1(i1, 6)                 arrD1(ct1, 7) = arrS1(i1, 7)                 ct1 = ct1 + 1             End If         Next     End With      With tws1         .Range("A1").Resize(UBound(arrD1, 1), UBound(arrD1, 2)) = arrD1         ReDim arrD1(1 To UBound(arrS1), 1 To 1)     End With  Erase arrS1 Erase arrD1 Set wb = Nothing Set ws = Nothing Set tws1 = Nothing Set rng = Nothing   End Sub