一个表单响应Cells.Clear /写入显着慢于其他
我有一个从大约100个其他工作簿的数据导入到ThisWorkbook中的3张。
子运行时，将清除先前加载到目标工作表中的所有数据。 我一直有Cells.Clear是一个快速的操作，但我注意到，其中一个工作表，特别是拖了很多，当我一步一步通过。 即使在运行Cells.Clear之前该工作表完全空白，情况也是如此。
此外，我还注意到，写入该表，并只有该表，现在也拖动。
我试过了：
- 使用function区手动清除违规表单中的所有内容
- 通过转到最后一个单元格检查隐藏的数据（最后一个单元格是A1）
- 运行VBA代码来清除此表单上的格式
近期变动：
- 昨天我把一个巨人分成了几个，事情变得很明显了。 也许我没有正确地做我的声明variables，等等？
- 我决定移动到Cells.Clear，并通过代码重新build立导入页面上的标题（而不是每次清除A3：Z1000000）
在这一点上，我最好的想法是尝试删除工作表并创build一个新工作表，但是我想了解可能会导致这种情况的原因，以及是否有办法通过不同的编码来避免这种情况。
完整的模块有406行代码，所以我会尽量只发布相关的代码。 如果你想看更多，只要问。
有问题的表是importedclinicdisp的临床performance。
缓慢的Cells.Clear代码
Sub ReconcileCCs() Dim importedclinicdisp As Worksheet Dim importedcc As Worksheet Dim importedophcc As Worksheet Set importedclinicdisp = ThisWorkbook.Worksheets(Sheet7.Name) 'Deposit Recon Imported CLINIC DISP tab Set importedcc = ThisWorkbook.Worksheets(Sheet8.Name) 'Deposit Recon Imported CREDIT CARD tab Set importedophcc = ThisWorkbook.Worksheets(Sheet13.Name) 'Deposit Recon Imported OPH CC Tab importedclinicdisp.Columns.Hidden = False 'Clear existing data importedclinicdisp.Cells.Clear importedcc.Cells.Clear importedophcc.Cells.Clear
慢导入代码
Sub ListFiles(fld As Object) Dim ddis As Workbook Dim ddis_depositdist As Worksheet Dim ddis_cctab As Worksheet Dim importedclinicdisp As Worksheet Dim importedcc As Worksheet Dim importedophcc As Worksheet Dim ddis_depositdistLastRow As Long Dim deposit_recon_cdLastRow As Long Dim deposit_recon_ccLastRow As Long Dim deposit_recon_cdNewLastRow As Long Dim ddis_cctabLastRow As Long Dim LastRow As Long Dim fl As Object 'File Set importedclinicdisp = ThisWorkbook.Worksheets(Sheet7.Name) 'Deposit Recon Imported CLINIC DISP tab Set importedcc = ThisWorkbook.Worksheets(Sheet8.Name) 'Deposit Recon Imported CREDIT CARD tab Set importedophcc = ThisWorkbook.Worksheets(Sheet13.Name) 'Deposit Recon Imported OPH CC Tab For Each fl In fld.Files Debug.Print fld.Path & "\" & fl.Name On Error GoTo WorkbookOpenFail Workbooks.Open (fl.Path) On Error GoTo 0 Set ddis = Workbooks(fl.Name) Set ddis_depositdist = ddis.Worksheets("CLINC DISP") Set ddis_cctab = ddis.Worksheets("CREDIT CARDS") '1.1 Import CLINIC DISP sheet of DDIS 'Find the last row of deposit recon cc tab With importedclinicdisp deposit_recon_cdLastRow = importedclinicdisp.Cells.Find(What:="*", _ After:=importedclinicdisp.Range("A1"), _ LookAt:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row If deposit_recon_cdLastRow < 3 Then deposit_recon_cdLastRow = 3 End With 'Paste the file name of the DDIS that is being imported from. importedclinicdisp.Range(Cells(deposit_recon_cdLastRow + 1, 1).Address, _ Cells(deposit_recon_cdLastRow + 72, 1).Address).Value = fl.Name 'Copy the clinic deposit distribution info from DDIS. importedclinicdisp.Range(Cells(deposit_recon_cdLastRow + 1, 2).Address, Cells(deposit_recon_cdLastRow + 72, 27).Address).Value = ddis_depositdist.Range("A3:Z74").Value '1.1.1 Import Ophthalmology information With importedophcc If Application.WorksheetFunction.CountA(importedophcc.Cells) <> 0 Then LastRow = 1 + importedophcc.Cells.Find(What:="*", After:=importedophcc.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row Else: LastRow = 3 End If End With ddis_depositdist.Range("A76:Z94").UnMerge importedophcc.Range(importedophcc.Cells(LastRow, 2), importedophcc.Cells(LastRow + 18, "Z")).Value = ddis_depositdist.Range("A76:Z94").Value importedophcc.Range(importedophcc.Cells(LastRow, 1), importedophcc.Cells(LastRow + 18, 1)).Value = ddis_depositdist.Range("I1").Value '1.2 Import CREDIT CARDS sheet of DDIS 'Find the last row on the credit cards import tab of Deposit Recon With importedcc If Application.WorksheetFunction.CountA(importedcc.Cells) <> 0 Then deposit_recon_ccLastRow = importedcc.Cells.Find(What:="*", _ After:=importedcc.Range("A1"), _ LookAt:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else deposit_recon_ccLastRow = 2 End If End With 'Find the last row on the CREDIT CARDS tab of DDIS With ddis_cctab If Application.WorksheetFunction.CountA(ddis_cctab.Cells) <> 0 Then ddis_cctabLastRow = ddis_cctab.Cells.Columns(1).Find(What:="*", _ After:=ddis_cctab.Range("A1"), _ LookAt:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else deposit_recon_ccLastRow = 2 End If End With 'Write the DDIS file imported from in the left-most column. importedcc.Range(Cells(deposit_recon_ccLastRow + 1, 1).Address, _ Cells(deposit_recon_ccLastRow + ddis_cctabLastRow - 4, 1).Address).Value = fl.Name 'Copy the CREDIT CARDS tab info from DDIS. importedcc.Range(Cells(deposit_recon_ccLastRow + 1, 2).Address, Cells(deposit_recon_ccLastRow + ddis_cctabLastRow - 4, 8).Address).Value = ddis_cctab.Range(Cells(5, 1).Address, Cells(ddis_cctabLastRow, 8).Address).Value 'End file handling code Workbooks(fl.Name).Close SaveChanges:=False NextWorkbook: Next Exit Sub WorkbookOpenFail: MsgBox (fl.Name & " could not be opened. The import will proceed to the next workbook.") Resume NextWorkbook End Sub
类RangeDataLoader
Option Explicit Private Const MaxRows As Long = 10000 Private DataArray As Variant Public DestinationColumn As Range Private row As Long Sub AddArray(SourceArray As Variant, Optional RepeatArray As Long = 1) Dim Target As Range Dim w As Long, x As Long, y As Long For w = 1 To RepeatArray For x = 1 To UBound(SourceArray, 1) If row = 0 Then ReDim DataArray(1 To MaxRows, 1 To UBound(SourceArray, 2)) row = row + 1 For y = 1 To UBound(SourceArray, 2) DataArray(row, y) = SourceArray(x, y) Next If row = MaxRows Then TransferData Next Next End Sub Sub TransferData() Dim Target As Range If IsEmpty(DataArray) Then Exit Sub With DestinationColumn Set Target = .Columns(1).Rows(.Parent.Rows.Count).End(xlUp).Offset(1) Target.Resize(row, UBound(DataArray, 2)) = DataArray End With row = 0 End Sub
处理文件夹中的文件
Sub LoadData(fld As Object) EventsTimer "Process Files" Dim temp(1 To 1, 1 To 1) Dim oFile As Object Dim wb As Workbook Dim DataLoaders(4) As RangeDataLoader Set DataLoaders(0) = New RangeDataLoader: Set DataLoaders(0).DestinationColumn = Sheet7.Columns("B") 'DISP.Range("A3:Z74") Set DataLoaders(1) = New RangeDataLoader: Set DataLoaders(1).DestinationColumn = Sheet13.Columns("A") 'DISP.Range("I1") Set DataLoaders(2) = New RangeDataLoader: Set DataLoaders(2).DestinationColumn = Sheet13.Columns("B") 'DISP.Range("A76:Z94") Set DataLoaders(3) = New RangeDataLoader: Set DataLoaders(3).DestinationColumn = Sheet8.Columns("A") 'FileName Set DataLoaders(4) = New RangeDataLoader: Set DataLoaders(4).DestinationColumn = Sheet8.Columns("B") 'CC.Range("A5", "H" & rwCC).Value For Each oFile In fld.Files On Error Resume Next Set wb = Workbooks.Open(Filename:=oFile.Path, ReadOnly:=True) On Error GoTo 0 If wb Is Nothing Then Debug.Print oFile.Path Else With wb.Worksheets("CLINC DISP") temp(1, 1) = .Range("I1").Value2 DataLoaders(0).AddArray .Range("A3:Z74").Value2 DataLoaders(1).AddArray temp, 19 DataLoaders(2).AddArray .Range("A76:Z94").Value2 End With With wb.Worksheets("CREDIT CARDS") With .Range("A5", .Range("H" & .Rows.Count).End(xlUp)) temp(1, 1) = oFile.Name DataLoaders(3).AddArray temp, .Rows.Count DataLoaders(4).AddArray .Value2 End With End With wb.Close End If Next DataLoaders(0).TransferData DataLoaders(1).TransferData DataLoaders(2).TransferData DataLoaders(3).TransferData DataLoaders(4).TransferData EventsTimer "Process Files" End Sub
事件计时器
Static Sub EventsTimer(Optional EventName As String) Dim dict As Object If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary") If dict.Exists(EventName) Then Debug.Print Debug.Print String(10, "-"), String(10, "-") Debug.Print EventName Debug.Print ; "Start Time:"; ; Now - dict(EventName) Debug.Print ; "End Time:"; ; Now Debug.Print ; "Duration:"; ; Timer - dict(EventName) & " Seconds" Debug.Print String(10, "-"); String(10, "-"); String(10, "-") dict.Remove EventName Else dict.Add EventName, CDbl(Timer) End If With Application .ScreenUpdating = dict.Count = 0 .EnableEvents = dict.Count = 0 .DisplayAlerts = dict.Count = 0 .Calculation = IIf(dict.Count = 0, xlCalculationAutomatic, xlCalculationManual) .CutCopyMode = dict.Count = 0 .DisplayStatusBar = dict.Count = 0 End With End Sub