Excel vba 运行缓慢，cpu 使用率高

Question

我实际上遇到了一个问题。我必须使用 Excel 来建立数据库，而且我遇到了一些麻烦。

我将 sheet 用作 table，并将列用作字段。一些 table 与其他具有 ID 字段的字段相关联，就像我们可以使用关系数据库所做的那样。

我的问题是我的一段代码运行真的很慢并且使用了我的 CPU.

的 60%

数据库用户需要在输入时实时查看他们正在操作的 table 中是否存在重复值。

Private Sub UserForm_Initialize()
    'Loading Form.
    Load Me
    
    'Initialisation of Filtered Data Sheet.
    Dim wsData As Worksheet
    Set wsData = Worksheets("DonneesFiltrees")
    
    'Disable screen update so the user do not see sheet with data wrote on it.
    Application.ScreenUpdating = False
    
    'Initialize the sheet the user wants to use.
    Set usingWs = Worksheets("Listes")
    usingWs.Visible = xlSheetVisible
    usingWs.Select
    
    'Sends data to Filtered Data Sheet.
    Call ModuleDonnees.TransferToFilterByName(usingWs, "Devises")
    
    'Populate the userForm list from Filtered Data Sheet
    Me.listExistants.ColumnCount = 1
    Me.listExistants.RowSource = populateList(wsData, "A")
    
End Sub

不幸的是，我在用户输入的每个字母上执行所有这些代码可能对 excel 来说太重了，但这是我老板的要求...

Private Sub txtNom_Change()
    
    'Initalize Filtered Data Sheet
    Dim wsData As Worksheet
    Dim FilteredRange As Range
    Set wsData = Worksheets("DonneesFiltrees")
    
    'Apply filter on Source Data Sheet. Sort of : Select * In 'myTable' Where Name Like 'UserRequest';
    usingWs.ListObjects("Devises").DataBodyRange.AutoFilter Field:=1, Criteria1:="=*" & Me.txtNom.Value & "*", Operator:=xlAnd
    
    
    'Get the Filtered Data Range
    On Error Resume Next
    Set FilteredRange = usingWs.ListObjects("Devises").DataBodyRange.SpecialCells(xlCellTypeVisible)
    
    'If the filtered data range is empty, the data doesn't exist, we can write it in the DB.
    If FilteredRange Is Nothing Then
        wsData.ListObjects(1).DataBodyRange.Clear
        isOk = True
    Else
        'If the filtered data range isn't empty refresh data by sending filtered data from source sheet
        'to the filtered data sheet. So the user see datas matching what he's typing.
        Call ModuleDonnees.TransferToFilterByName(usingWs, "Devises")
        
        isOk = False
    End If
    
End Sub

Private Sub btnAjout_Click()
    
    Dim newRow As ListRow
    
    
    'Clearing Filter
    usingWs.ListObjects("Devises").AutoFilter.ShowAllData
    
    'This Condition is used to Match if the data really exist
    'Lets admit than the user wants to write Ira as a country
    'Iraq and Iran exists and will be in the list of existing values but are not exactly the same
    'in this case we should let the user write it.
    If isOk = False Then
        
        i = 0
        
        Do While (i < Me.listExistants.ListCount - 1)
            If Me.listExistants.List(i) = Me.txtNom.Value Then
                isOk = False
                Exit Do
            Else
                isOk = True
                i = i + 1
            End If
        Loop
    
    End If
    
    If isOk = True Then
    
        'Asking for validation before he write the data.
        Confirmation = MsgBox("Voulez-vous confirmer la saisie de données ?", 36, "Confirmation")
        
        If Confirmation = vbNo Then
            MsgBox "Saisie annulée"
            Exit Sub
        ElseIf Confirmation = vbYes Then
        
        
            
            'Add row
            Set newRow = usingWs.ListObjects("Devises").ListRows.Add
            
            'Write the value
            With newRow
                .Range(1) = Me.txtNom.Value
            End With
            
            'Validation Message
            MsgBox "La devise a bien été ajouté à la base de données"
    
            'Closing Form
            Unload Me
    
    Else
        'If is Ok still false it means that the data already exists in database so we block the user
        
        MsgBox "Il semblerait que votre saisie existe déjà dans la base de données"
        Unload Me
        Exit Sub
    End If
    
End Sub

有我的导入数据方法，

'As I'm using tables I copy the header range and then body range and transform it to a table
Function TransferToFilterByName(ws As Worksheet, tableName As String)

    Dim wsData As Worksheet
    Set wsData = Worksheets("DonneesFiltrees")
    Dim FilteredRange As Range
    
    wsData.Cells.Clear


    ws.Visible = xlSheetVisible
    ws.Select
    ws.ListObjects(tableName).HeaderRowRange.Copy Destination:=wsData.Range("A1")
    
    
    ws.Select
    Set FilteredRange = ws.ListObjects(tableName).DataBodyRange.SpecialCells(xlCellTypeVisible)
    
    FilteredRange.Copy Destination:=wsData.Range("A2")

    Call ConvertToTable

End Function

Function ConvertToTable()

    Dim tbl As Range
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    
    Set ws = Worksheets("DonneesFiltrees")
    Set tbl = ws.Range("A1").CurrentRegion
    
    ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=tbl, xllistobjecthasheaders:=xlYes).Name = "DonneesFiltrees"
    
End Function

我的所有代码都用于向某些 sheet 添加数据，但正如我之前所说，这使用了我 CPU 的 50% 到 60%，这是运行有点慢，尽管数据量很少。

这仅仅是因为在 userForm txtBox_Change() 上执行它吗？或者有什么办法可以在不改变的情况下进行优化

任何帮助将不胜感激。

提前致谢。

Answer 1

我承认我并没有完全遵循您的所有逻辑，因为在过滤您的 Devises table 并检查可见行之后，似乎保持过滤，即使没有任何？有些 re-organisation 我会建议（据我了解您的代码）不要在 txtNom_Change()[ 中进行 any 过滤=19=] - 而只是使用 WorksheetFunction 对象的 MATCH() 方法，因为它很乐意处理通配符。然后，在 TransferToFilterByName() 过程中对您的 Devises table 进行实际过滤 always 是必要的。（基于 FunThomas 的评论，因为您已经知道 SQL，this 是关于如何在 Excel 中使用 it/ADODB 的优秀播放列表）

Excel vba 运行缓慢，cpu 使用率高

Excel vba runing slowly, high cpu usage

excel

vba

database

optimization