Question

我有一个sub，它将ThisWorkbook中大约100个其他工作簿的数据导入3张。

子运行时，它会清除以前在目标工作表中加载的所有数据。我一直都有Cells.Clear是一个快速的操作，但是我注意到当我单步执行时，其中一个工作表特别拖延了。即使在运行Cells.Clear之前该表完全空白也是如此。

此外，我还注意到写入该表，只有那张表，现在也在拖动。

我试过了：

使用功能区
通过Go To Last Cell（最后一个单元格为A1）检查隐藏数据
运行VBA代码以清除此工作表上的格式

最近的变化：

昨天我把一个巨大的子分成几个后，事情变得明显了。也许我对如何声明变量等没有做正确的事情？
我决定转移到Cells.Clear并按代码重新建立导入页面上的标题（而不是每次清除A3：Z1000000）

此时我最好的想法是尝试删除工作表并制作一个新工作表，但我想了解可能导致此问题的原因，以及是否有办法通过不同的编码来避免这种情况。

完整模块有406行代码，因此我将尝试仅发布相关代码。如果你想看到更多，请问。

违规表格为importedclinicdisp。

Slow Cells.Clear Code

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

Answer 1

类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

一张响应Cells.Clear /写入的表单明显慢于其他表单

1 个答案:

类RangeDataLoader

处理文件夹

事件计时器