Question

大家好，并提前致谢，

我是VBA编码的新手，并且一直在制作一个电子表格，用于搜索关键字的问题和答案列表。我已经按照我想要的方式完成所有工作，但运行需要很长时间。

基本上，数据全部位于与搜索按钮相同的电子表格中的隐藏行中，有五列可以搜索，每列都有一个复选框，选中此复选框表示该列包含在过滤器中。用户输入他们的关键字，然后宏设置高级过滤器，并在另一张纸上查找。然后显示符合标准的行，而其他行仍保持隐藏状态。

我已尝试过一些方法来加速宏，但仍需要很长时间。行数越多，符合标准的时间越长。

我期待听到您的想法！

我在下面添加了我的代码。

马特

Sub Macro7()


With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
End With

Dim searchthis As String
Dim vCount As Integer
Dim vCell As String
Dim vContent As String
Dim vRange As String
Dim vHiddenT As Integer
Dim vHiddenF As Integer
vCount = 0
searchthis = InputBox("Type criteria to search to data", "Proposal Answers Search")

If searchthis = "" Then
    vCount = MsgBox("No search criteria entered", vbOKOnly, "Proposal Answers Search")
    Exit Sub
End If

If Len(searchthis) < 3 Then
    vCount = MsgBox("Are you sure that you wish to search for:  " & searchthis & "?", vbYesNo, "Proposal Answers Search")
    If vCount = 7 Then
        Exit Sub
    End If
End If

Dim vArray As Variant
vArray = MySplitFunction(searchthis)
Sheets("LookupRange").Activate
Sheets("LookupRange").Cells.Select
Sheets("LookupRange").Range("A1").Activate
Selection.ClearContents
Sheets("LookupRange").Range("A1") = "RFP Name"
Sheets("LookupRange").Range("B1") = "Question #"
Sheets("LookupRange").Range("C1") = "Question Title"
Sheets("LookupRange").Range("D1") = "Question"
Sheets("LookupRange").Range("E1") = "Answer"
vCount = 0
vContent = vArray(0)

If UBound(vArray) > 0 Then
    For i = 1 To UBound(vArray)
        vContent = vContent & vArray(i)
    Next
End If

Dim vArray2 As Variant
Dim vCell3 As String
vArray2 = CheckBoxCheck

If UBound(vArray2) >= 1 Then
    For i = 0 To UBound(vArray2) - 1
        vCell3 = vArray2(i)
        Sheets("LookupRange").Range(vCell3) = vContent
    Next
Else
    vCount = MsgBox("No CheckBox selected", vbOKOnly, "Proposal Answers Search")
    Exit Sub
End If

Dim aRng As Range
Dim FirstCell As String
Dim LastCell As String
Sheets("LookupRange").Activate
Set aRng = Sheets("LookupRange").Range("A1").CurrentRegion
FirstCell = "A1"
LastCell = "E" & aRng.Rows.Count
vRange = FirstCell & ":" & LastCell

Sheets("Data").Activate
Sheets("Data").Range("A327").Activate

Do
        ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""

vHiddenF = ActiveCell.Row
vStr = "A6:E" & vHiddenF - 1

Application.CutCopyMode = False
Range(vStr).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("LookupRange").Range(vRange), Unique:=False

Sheets("Data").Range("A1") = "Search Term"
Sheets("Data").Range("A2") = searchthis
Sheets("Data").Range("A6") = "RFP Name"
Sheets("Data").Range("B6") = "Question #"
Sheets("Data").Range("C6") = "Question Title"
Sheets("Data").Range("D6") = "Question"
Sheets("Data").Range("E6") = "Answer"
Sheets("Data").Range("A1").Activate

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub



Function MySplitFunction(s As String) As String()

Dim temp As String
Dim Output() As String

Do
    temp = s
    s = Replace(s, "  ", " ")
Loop Until temp = s

Output = Split(Trim(s), " ")

For i = 0 To UBound(Output)
    Output(i) = "*" & Output(i) & "*"
Next

MySplitFunction = Output

End Function



Function CheckBoxCheck() As String()

Dim vTemp As String
Dim vOutput() As String
Dim vCount As Integer
vCount = 2

If Sheets("Data").Shapes("Check Box 7").ControlFormat.Value = 1 Then
    vTemp = "A" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 8").ControlFormat.Value = 1 Then
    vTemp = vTemp & "B" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 9").ControlFormat.Value = 1 Then
    vTemp = vTemp & "C" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 10").ControlFormat.Value = 1 Then
    vTemp = vTemp & "D" & vCount
    vCount = vCount + 1
End If

If Sheets("Data").Shapes("Check Box 11").ControlFormat.Value = 1 Then
    vTemp = vTemp & "E" & vCount
End If

Dim sArr() As String
Dim nCount As Long
Dim numOfChar As Integer
numOfChar = 2
ReDim sArr(Len(vTemp) \ numOfChar)

Do While Len(vTemp)
    sArr(nCount) = Left$(vTemp, numOfChar)
    vTemp = Mid$(vTemp, numOfChar + 1)
    nCount = nCount + 1
Loop

CheckBoxCheck = sArr

End Function

Answer 1

你的主要罪魁祸首可能是：

Sheets("Data").Activate
Sheets("Data").Range("A327").Activate

Do
    ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""

The Active＆amp;如果您有大量数据并且会耗费处理时间，则select可循环使用数百个单元格。看来你只是在寻找下一个空行。试着用一行来代替以上所有：

vHiddenF = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row + 1

以下是一些建议的方法来摆脱主宏中的Select和Active语句：

Sub Macro7()
    With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
    End With

    Dim searchthis As String
    Dim vCount As Integer
    Dim vCell As String
    Dim vContent As String
    Dim vRange As String
    Dim vHiddenT As Integer
    Dim vHiddenF As Integer
    vCount = 0
    searchthis = InputBox("Type criteria to search to data", "Proposal Answers Search")

    If searchthis = "" Then
        vCount = MsgBox("No search criteria entered", vbOKOnly, "Proposal Answers Search")
        Exit Sub
    End If

    If Len(searchthis) < 3 Then
        vCount = MsgBox("Are you sure that you wish to search for:  " & searchthis & "?", vbYesNo, "Proposal Answers Search")
        If vCount = 7 Then
            Exit Sub
        End If
    End If

    Dim wkLookUpRange As Worksheet
    Set wkLookUpRange = Sheets("LookupRange")

    Dim vArray As Variant
    vArray = MySplitFunction(searchthis)

    wkLookUpRange.Cells.ClearContents
    wkLookUpRange.Range("A1") = "RFP Name"
    wkLookUpRange.Range("B1") = "Question #"
    wkLookUpRange.Range("C1") = "Question Title"
    wkLookUpRange.Range("D1") = "Question"
    wkLookUpRange.Range("E1") = "Answer"
    vCount = 0
    vContent = vArray(0)

    If UBound(vArray) > 0 Then
        For i = 1 To UBound(vArray)
            vContent = vContent & vArray(i)
        Next
    End If

    Dim vArray2 As Variant
    Dim vCell3 As String
    vArray2 = CheckBoxCheck

    If UBound(vArray2) >= 1 Then
        For i = 0 To UBound(vArray2) - 1
            vCell3 = vArray2(i)
            wkLookUpRange.Range(vCell3) = vContent
        Next
    Else
        vCount = MsgBox("No CheckBox selected", vbOKOnly, "Proposal Answers Search")
        Exit Sub
    End If

    Dim aRng As Range
    Dim FirstCell As String
    Dim LastCell As String

    Set aRng = wkLookUpRange.Range("A1").CurrentRegion
    FirstCell = "A1"
    LastCell = "E" & aRng.Rows.Count
    vRange = FirstCell & ":" & LastCell

    Dim wkData As Worksheet
    Set wkData = Sheets("Data")

    vHiddenF = wkData.Range("A" & Rows.Count).End(xlUp).Row + 1

    vStr = "A6:E" & vHiddenF - 1

    Application.CutCopyMode = False
    wkData.Range(vStr).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
    wkLookUpRange.Range(vRange), Unique:=False

    wkData.Range("A1") = "Search Term"
    wkData.Range("A2") = searchthis
    wkData.Range("A6") = "RFP Name"
    wkData.Range("B6") = "Question #"
    wkData.Range("C6") = "Question Title"
    wkData.Range("D6") = "Question"
    wkData.Range("E6") = "Answer"
    wkData.Range("A1").Activate

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Excel中的AdvancedFilter运行速度非常慢

1 个答案: