Excel 根据“年”列中的“最大数”将下一年的日期导入表，我的代码冻结

我有一个表，其中有重复的公司名称，因为它们每个都有一行基于年度值的数据。我一直在尝试创建一个导入代码，为每个公司添加一行，并添加下一年的详细信息。我的代码过滤E列，其中包含年份，从最小到最大的数字。我使用max代码来获取最大数的第一个实例。然后我得到最后一行号和最后一行号加1的值。然后我可以复制并粘贴范围到下一个空行。然后，我需要清除H列和N列至AD列中的范围。我需要确保J:K列为dd/mm/yyyy格式，以便我的代码仅更改J列和K列中日期的年份。我下面的代码可以工作，但运行可能需要20到30分钟。而且会冻僵。我的电脑规格很好，所以不知道为什么这一小段代码要花这么长时间。任何帮助都将不胜感激，因为我已经花了数小时寻找解决方案

Sub AddNewYear()
othwb = Application.Workbooks.Count
If othwb > 1 Then MsgBox "Please save and close any other workbooks before running this code", , "Panda": Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim d As Date
Dim da As Date
Dim lrow As Long
Dim copy_range As Range
lrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ActiveWorkbook.Worksheets("Financial Data").Range("J2", "K200000") = Format(Date, "dd/mm/yyyy")
lrow1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim tabl As ListObject
Set tabl = Sheet1.ListObjects(1)
Sheet1.ListObjects.item(1).ShowTotals = False
Dim orgid As String
Dim yearchoice As Variant
tabl.AutoFilter.ShowAllData
yearchoice = Application.WorksheetFunction.Max(Range("E:E"))
Set copy_range = Sheet1.Range("A2:AZ" & lrow)
tabl.Range.AutoFilter Field:=5, Criteria1:=yearchoice
copy_range.SpecialCells(xlCellTypeVisible).Copy Sheet1.Range("A" & lrow1)
tabl.AutoFilter.ShowAllData
Dim lrow2
lrow2 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Range("H" & lrow1 & ":H" & lrow2).ClearContents
Sheet1.Range("N" & lrow1 & ":AD" & lrow2).ClearContents
Dim x
yearchoice = yearchoice + 1
For x = lrow1 To lrow2
Sheet1.Range("E" & x).Value = yearchoice
Sheet1.Range("F" & x).Value = "A"
Sheet1.Range("G" & x).Value = yearchoice & Sheet1.Range("F" & x).Value
Sheet1.Range("H" & x).Value = 0
d = Sheet1.Range("J" & x).Value
Sheet1.Range("J" & x).Value = DateSerial(year(d) + 1, Month(d), Day(d))
da = Sheet1.Range("K" & x).Value
Sheet1.Range("K" & x).Value = DateSerial(year(da) + 1, Month(da), Day(da))
Next x
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

---

如果你能提供一个输入样本，那就容易多了。我们不知道您的范围有多大。目前有15568行数据，需要复制和粘贴1386行。A列：诱饵似乎是这行代码导致了应用程序.ActiveWorkbook.Worksheets（“财务数据”）.Range（“J2”，“K200000”）=格式（日期，“dd/mm/yyyy”）应该是

Application.ActiveWorkbook.Worksheets（“财务数据”）.Range（“J2”，“K200000”）.NumberFormat=“dd/mm/YYYYYY”