Question

我编写了一个分析工作表（8000行和40列）并返回所有相关产品ID的程序，但我的程序运行速度慢得令人难以忍受，运行大约需要5分钟，所以在寻找方法加快速度我遇到了一些禁用屏幕更新，显示状态栏，计算和事件的代码。它使程序运行时间加倍（从5分钟到10分钟）但是我需要程序能够更快地运行。我一直在搜索并遇到 This 这似乎正是我所需要的，但我并不完全理解如何实现它。

让我解释一下我的代码需要做什么，也许你可以帮助我找到更好的方法。告诉您有关信息的信息可能会有所帮助。我在一家销售皮套的公司工作，我们正试图找到一种方法来收集所有产品ID，用于不同类型的皮套，一起喷枪。因此，在第一列中我们有Gun名称，在第四列中我们有Holster类型，在第12列中我们有产品ID＃。

我要做的是对于任何给定的行，让程序查看文件的其余部分并返回第33-39行中匹配产品（具有完全相同名称的产品）的产品ID，即第33列将具有相关的隐藏式皮套，34将具有相关的踝部皮套等。

我已经编写了一个代码来执行此操作但是如何使用此命名的DataRange方法执行此操作？

Do
    ActiveCell.Offset(1, 0).Activate
    Location = ActiveCell.Address
    GunName = ActiveCell.Value
    X = 0
    Range("A1").Activate

    Do
        If ActiveCell.Offset(X, 0).Value = GunName Then
        PlaceHolder = ActiveCell.Address
            If ActiveCell.Offset(X, 3).Value = "CA" Then
                Range(Location).Offset(0, 34).Value = ActiveCell.Offset(X, 12).Value
            ElseIf ActiveCell.Offset(X, 3).Value = "AA" Or ActiveCell.Offset(X, 3).Value = "AR" Then
                If ActiveCell.Offset(X, 4).Value = "NA-LH" Or ActiveCell.Offset(X, 4).Value = "NA" Or ActiveCell.Offset(X, 4).Value = "11-LH" Or ActiveCell.Offset(X, 4).Value = "13-LH" Or ActiveCell.Offset(X, 4).Value = "12-A-LH" Or ActiveCell.Offset(X, 4).Value = "12-B-LH" Or ActiveCell.Offset(X, 4).Value = "12-C-LH" Or ActiveCell.Offset(X, 4).Value = "12-JB-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-b-LH" Or ActiveCell.Offset(X, 4).Value = "11-LS-LH" Or ActiveCell.Offset(X, 4).Value = "21L" Then

                Else
                    Range(Location).Offset(0, 35).Value = ActiveCell.Offset(X, 12)
            End If
            ElseIf ActiveCell.Offset(X, 3).Value = "BA" Or ActiveCell.Offset(X, 3).Value = "BR" Then
                Range(Location).Offset(0, 36).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "HA" Or ActiveCell.Offset(X, 3).Value = "HR" Then
                Range(Location).Offset(0, 37).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "VA" Or ActiveCell.Offset(X, 3).Value = "VR" Then
                Range(Location).Offset(0, 38).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "TA" Or ActiveCell.Offset(X, 3).Value = "TR" Then
                Range(Location).Offset(0, 39).Value = ActiveCell.Offset(X, 12)
            End If
        End If
        X = X + 1
    Loop Until IsEmpty(ActiveCell.Offset(X, 0).Value)
    ActiveCell.Range(Location).Activate
Loop Until IsEmpty(ActiveCell.Value)

AA，BA CA等是皮套类型。

Answer 1

修改的

查看示例文件并通过以下注释澄清后，这是更新的代码。我相信这对你有用：

Sub tgr()

    Dim rngData As Range
    Dim GunCell As Range
    Dim rngFound As Range
    Dim arrResults() As Variant
    Dim ResultIndex As Long
    Dim cIndex As Long
    Dim strFirst As String
    Dim strTemp As String

    On Error Resume Next
    With Range("DataRange")
        .Sort .Resize(, 1), xlAscending, Header:=xlYes
        Set rngData = .Resize(, 1)
    End With
    On Error GoTo 0
    If rngData Is Nothing Then Exit Sub   'No data or no named range "DataRange"

    With rngData
        ReDim arrResults(1 To .Rows.Count, 1 To 6)
        For Each GunCell In .Cells
            If GunCell.Row > 1 Then
                ResultIndex = ResultIndex + 1
                If LCase(GunCell.Text) <> strTemp Then
                    strTemp = LCase(GunCell.Text)
                    Set rngFound = .Find(strTemp, .Cells(.Cells.Count), xlValues, xlWhole)
                    If Not rngFound Is Nothing Then
                        strFirst = rngFound.Address
                        Do
                            If InStr(1, " CA BA HA VA TA ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 Then
                                Select Case UCase(.Parent.Cells(rngFound.Row, "D").Text)
                                    Case "CA":  cIndex = 1
                                    Case "BA":  cIndex = 3
                                    Case "HA":  cIndex = 4
                                    Case "VA":  cIndex = 5
                                    Case "TA":  cIndex = 6
                                End Select
                                arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
                            ElseIf InStr(1, " AA AR ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 _
                            And InStr(1, " NA-LH NA 11-LH 13-LH 12-A-LH 12-B-LH 12-C-LH 12-JB-LH 12-LS-LH 12-LS-b-LH 11-LS-LH 21L ", " " & .Parent.Cells(rngFound.Row, "E").Text & " ", vbTextCompare) = 0 Then
                                cIndex = 2
                                arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
                            End If
                            Set rngFound = .Find(strTemp, rngFound, xlValues, xlWhole)
                        Loop While rngFound.Address <> strFirst
                    End If
                Else
                    For cIndex = 1 To UBound(arrResults, 2)
                        arrResults(ResultIndex, cIndex) = arrResults(ResultIndex - 1, cIndex)
                    Next cIndex
                End If
            End If
        Next GunCell
    End With

    Range("AI2:AI" & Rows.Count).Resize(, UBound(arrResults, 2)).ClearContents
    If ResultIndex > 0 Then Range("AI2").Resize(ResultIndex, UBound(arrResults, 2)).Value = arrResults

End Sub

Answer 2

避免.Activate，这非常缓慢且通常无用。而是尝试这种风格的东西：

Option Explicit

Sub sample()
    Dim c As Range

    For Each c In Range("a:a").SpecialCells(xlCellTypeConstants)
        If c.Offset(x, 0).Value = GunName Then
            'etc etc
        End If
    Next c

End Sub

哦，哦！并确保使用Option Explicit和Dim变量。它不是为了速度，而是为了避免错误。并使用评论;-)

如何使用命名范围加速VBA代码？

2 个答案: