时间戳

首页 > 解决方案 > 如何有效控制多个嵌套循环而不会出现 RT 错误？

excel - 如何有效控制多个嵌套循环而不会出现 RT 错误？

问题描述

我一直在玩这个代码一段时间了。我希望它写得足够​​好，可以被理解。我正在尝试做一个查询，首先尝试匹配两个值，项目描述。如果成功，如果材料代码匹配，我还想从同一行中进行下一步。如果它们都匹配，那么在价格匹配的同一行上，我想从 SF 获取结果并将其带入 SAP。

收到的错误是“用于控制已在使用中”，我有点收集。请问这将如何适当地完成？

见下文

Private Sub CommandButton1_Click()

Dim SAP As Range
    Set SAP = ThisWorkbook.Worksheets("SAP").UsedRange
Dim SF As Range
    Set SF = ThisWorkbook.Worksheets("SF").UsedRange
    
Dim SAPProjectDesc As Range
    Set SAPProjectDesc = SAP.Columns(5)
Dim SFProjectDesc As Range
    Set SFProjectDesc = SF.Columns(4)
    
Dim SAPSFBuyPrice As Range
    Set SAPSFBuyPrice = SAP.Columns(16)
Dim SAPSFSellPrice As Range
    Set SAPSFSellPrice = SAP.Columns(17)
Dim SFBuyPrice As Range
    Set SFBuyPrice = SF.Columns(27)
Dim SFSellPrice As Range
    Set SFSellPrice = SF.Columns(25)
Dim SFMaterialCode As Range
    Set SFMaterialCode = SF.Columns(23)
 Dim SAPMaterialCode As Range
    Set SAPMaterialCode = SAP.Columns(14)
    
Dim i As Long
Dim c As Range

For i = 2 To SAPProjectDesc.Rows.Count
    For Each c In SFProjectDesc.Cells
        If c.Value2 = SAPProjectDesc.Rows(i).Value2 Then
            For Each c In SFMaterialCode.Cells
                If c.Value2 = SAPMaterialCode.Rows(i).Value2 Then
                ''MATCH CODE GOES HERE
                J = c.Row
                SAP.Activate
                SAPSFSellPrice.Rows(i).Activate
                SAPSFSellPrice.Rows(i).Value2 = SFSellPrice.Rows(J).Value2
                SAPSFBuyPrice.Rows(i).Value2 = SFBuyPrice.Rows(J).Value2
                Else
                ''Found a Project but not a material code
                MsgBox "Found a Project Name Match but not a material Code match"
                End If
            Next
        Else
        ''Didnt find a project match
        MsgBox "Didnt Find a Project Match"
        End If
    Next
Next
End Sub

标签： excelvbaloops

解决方案

更新工作表

  • 第一个代码updatePricesQF是中间慢速快速修复（独立）。我相信你能弄清楚。
  • 第二，主要代码updatePrices，是一个先进的快速解决方案。它正在使用剩下的两个程序。它可能仍然可以优化以运行得更快，但我已经拥有它。
  • 通常将代码复制到标准模块（例如Module1）中，然后使用Call updatePrices或仅updatePrices在命令按钮单击事件代码中使用，这也使得它更容易应用于许多按钮。

编码

Option Explicit

Sub updatePricesQF() ' Slow: it took 45 sec for 10000 rows of values only.
    
    ' SF (Source)
    Dim SF As Range:  Set SF = ThisWorkbook.Worksheets("SF").UsedRange
    Dim SFProjectDesc As Range:   Set SFProjectDesc = SF.Columns(4)
    Dim SFMaterialCode As Range:  Set SFMaterialCode = SF.Columns(23)
    Dim SFBuyPrice As Range:      Set SFBuyPrice = SF.Columns(27)
    Dim SFSellPrice As Range:     Set SFSellPrice = SF.Columns(25)
    
    ' SAP (Target)
    Dim SAP As Range: Set SAP = ThisWorkbook.Worksheets("SAP").UsedRange
    Dim SAPProjectDesc As Range:  Set SAPProjectDesc = SAP.Columns(5)
    Dim SAPMaterialCode As Range: Set SAPMaterialCode = SAP.Columns(14)
    Dim SAPBuyPrice As Range:     Set SAPBuyPrice = SAP.Columns(16)
    Dim SAPSellPrice As Range:    Set SAPSellPrice = SAP.Columns(17)
    
    ' Program
    Application.ScreenUpdating = False
    Dim Pro As Variant, Mat As Variant, i As Long, k As Long
    For i = 2 To SAPProjectDesc.Rows.Count
        Pro = SAPProjectDesc.Rows(i).Value
        Mat = SAPMaterialCode.Rows(i).Value
        For k = 2 To SFProjectDesc.Rows.Count
            If SFProjectDesc.Rows(k) = Pro Then
                If SFMaterialCode.Rows(k).Value = Mat Then
                    SAPSellPrice.Rows(i).Value = SFSellPrice.Rows(k).Value
                    SAPBuyPrice.Rows(i).Value = SFBuyPrice.Rows(k).Value
                    Exit For ' Only one combination of "ProjectDesc" and
                             ' "MaterialCode" in "SF" is expected.
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
    
    MsgBox "Prices updated.", vbInformation, "Success"

End Sub

Sub updatePrices() ' Fast: it took 3 sec for 10000 rows of values only.

    ' SF
    Const srcName As String = "SF"
    Const srcFirstRow As Long = 2
    Const srcLastRowCol As Variant = 4
    Dim srcCols As Variant: srcCols = Array(4, 23, 27, 25)
    ' SAP
    Const tgtName As String = "SAP"
    Const tgtFirstRow As Long = 2
    Const tgtLastRowCol As Variant = 5
    Dim tgtCols As Variant: tgtCols = Array(5, 14, 16, 17)
    ' Other
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write columns to arrays.
    Dim rng As Range, j As Long
    Dim ubc As Long: ubc = UBound(srcCols)
    ' Write values of Source Columns to jagged Source Array.
    Dim src As Worksheet: Set src = wb.Worksheets(srcName)
    getColumnRangeUsingColumnID rng, src, srcLastRowCol, srcFirstRow
    If rng Is Nothing Then Exit Sub
    Dim Source As Variant: ReDim Source(ubc)
    For j = 0 To ubc
        getRange Source(j), rng.Offset(, srcCols(j) - srcLastRowCol)
    Next j
    ' Write values of Target Columns to jagged Target Array.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
    getColumnRangeUsingColumnID rng, tgt, tgtLastRowCol, tgtFirstRow
    If rng Is Nothing Then Exit Sub
    Dim Target As Variant: ReDim Target(ubc)
    For j = 0 To ubc
        getRange Target(j), rng.Offset(, tgtCols(j) - tgtLastRowCol)
    Next j
    
    ' Modify values in jagged Target Array.
    Dim ubt As Variant: ubt = UBound(Target(0))
    Dim ubs As Variant: ubs = UBound(Source(0))
    Dim Pro As Variant, Mat As Variant, i As Long, k As Long
    For i = 1 To ubt
        Pro = Target(0)(i, 1)
        Mat = Target(1)(i, 1)
        For k = 1 To ubs
            If Source(0)(k, 1) = Pro Then
                If Source(1)(k, 1) = Mat Then
                    For j = 2 To 3
                        Target(j)(i, 1) = Source(j)(k, 1)
                    Next j
                    Exit For
                End If
            End If
        Next k
    Next i
        
    ' Copy values from jagged Target Array to Target Column Ranges.
    For j = 2 To 3
        rng.Offset(, tgtCols(j) - tgtLastRowCol).Value = Target(j)
    Next j
    
    ' Inform user.
    MsgBox "Prices updated.", vbInformation, "Success"

End Sub

' Writes the values of a range to a 2D one-based array.
Sub getRange(ByRef Data As Variant, SourceRange As Range)
    
    Data = Empty
    If SourceRange Is Nothing Then Exit Sub
    
    If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
        Data = SourceRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = SourceRange.Value
    End If
    
End Sub

' Defines the column range of a given column starting from a given
' first row and ending with the last non-blank cell.
' If NoEmpties is set to True, it will not consider the bottom cells possibly
' containing a formula evaluating to "".
Sub getColumnRangeUsingColumnID(ByRef ColumnRange As Range, _
                                Optional Sheet As Worksheet = Nothing, _
                                Optional ByVal ColumnID As Variant = 1, _
                                Optional ByVal FirstRow As Long = 1, _
                                Optional ByVal NoEmpties As Boolean = False)
    
    Set ColumnRange = Nothing
    If Sheet Is Nothing Then Set Sheet = ActiveSheet
    
    Dim FormVal As XlFindLookIn
    If NoEmpties Then FormVal = xlValues Else FormVal = xlFormulas
    
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnID).Find("*", , FormVal, , , xlPrevious)
    If rng Is Nothing Then Exit Sub     ' Empty Column.
    If rng.Row < FirstRow Then Exit Sub ' Last Row is below First Row.
    Set ColumnRange = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng)

End Sub

推荐阅读