0

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

让我解释一下我的代码需要做什么，也许你可以帮助我找到更好的方法。告诉您这些信息的内容可能会有所帮助。我在一家销售枪套的公司工作，我们正试图找到一种方法来收集所有用于 1 支枪的不同类型枪套的产品 ID。所以在第一列我们有枪名称，在第 4 列我们有皮套类型，在第 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 等是皮套类型。

4

2 回答 2

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
于 2013-09-05T19:49:05.520 回答
1

避免.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的变量。这不是为了速度，而是为了避免错误。并使用评论;-)

于 2013-09-05T20:18:40.703 回答