如何乘以循环。 VBA

问题描述 投票：0回答：2

我需要我的程序来识别类型是水果还是沙拉，以及它的形状是好是坏。 取决于它必须乘以 Prcies*Stock.

所以我做了这段代码，但是当它超过 5000 行时，它真的很慢。 我怎么能不使用 out loopin 来做到这一点？

Sub Go()

Set Page1 = Worksheets("Page 1")

LastRow = Page1.Cells(Page1.Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow

If Range("B" & i).Value = "fruit" And Range("C" & i).Value = "good" Then
    Range("E" & i).Value = Range("D" & i) * Range("I2").Value
        Else
            If Range("B" & i).Value = "fruit" And Range("C" & i).Value = "bad" Then
                Range("E" & i).Value = Range("D" & i).Value * Range("J2").Value
        Else
            If Range("B" & i).Value = "salad" And Range("C" & i).Value = "good" Then
                Range("E" & i).Value = Range("D" & i) * Range("I3").Value
        Else
            If Range("B" & i).Value = "salad" And Range("C" & i).Value = "bad" Then
                Range("E" & i).Value = Range("D" & i) * Range("J3").Value
        Else
             Range("E" & i).Value = "error"
            End If
            End If
            End If
End If

Next

End Sub

excel vba
2个回答
1
投票

VBA 查找

使用字典

  • 应该比 Application.Match 解决方案更有效（更快）。欢迎您的反馈。
Sub CalcTotalsDict()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Sheets("Page 1")
    
    Dim srg As Range, rCount As Long
    
    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        Set srg = .Resize(rCount).Offset(1)
    End With
    
    Dim sData(): sData = srg.Value
    
    Dim lPrices(), lTypes(), lStates(), lrCount As Long, lcCount As Long
    
    With ws.Range("H1").CurrentRegion
        lrCount = .Rows.Count - 1
        lcCount = .Columns.Count - 1
        lTypes = .Resize(lrCount, 1).Offset(1).Value
        lStates = .Resize(1, lcCount).Offset(, 1).Value
        lPrices = .Resize(lrCount, lcCount).Offset(1, 1).Value
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim lr As Long, lc As Long, lStr As String
    
    For lr = 1 To lrCount
        For lc = 1 To lcCount
            lStr = CStr(lTypes(lr, 1)) & "@" & CStr(lStates(1, lc))
            If Not dict.Exists(lStr) Then
                dict(lStr) = lPrices(lr, lc)
            End If
        Next lc
    Next lr
                
    Dim dData(): ReDim dData(1 To rCount, 1 To 1)
    
    Dim r As Long, sStr As String
    
    For r = 1 To rCount
        sStr = CStr(sData(r, 2)) & "@" & CStr(sData(r, 3))
        If dict.Exists(sStr) Then
            dData(r, 1) = dict(sStr) * sData(r, 4)
        Else
            dData(r, 1) = "Error"
        End If
    Next r

    srg.Columns(5).Value = dData
    
    MsgBox "Totals calculated.", vbInformation

End Sub

使用 Application.Match

Sub CalcTotalsMatch()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Sheets("Page 1")
    
    Dim srg As Range, rCount As Long

    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        Set srg = .Resize(rCount).Offset(1)
    End With
    
    Dim sData(): sData = srg.Value
    
    Dim lPrices(), lTypes(), lStates(), lrCount As Long, lcCount As Long
    
    With ws.Range("H1").CurrentRegion
        lrCount = .Rows.Count - 1
        lcCount = .Columns.Count - 1
        lTypes = .Resize(lrCount, 1).Offset(1).Value
        lStates = .Resize(1, lcCount).Offset(, 1).Value
        lPrices = .Resize(lrCount, lcCount).Offset(1, 1).Value
    End With
    
    Dim dData(): ReDim dData(1 To rCount, 1 To 1)
    
    Dim lrIndex, lcIndex, r As Long, IsFound As Boolean
    Dim sType As String, sState As String, sStock As Long
    
    For r = 1 To rCount
        sType = CStr(sData(r, 2))
        lrIndex = Application.Match(sType, lTypes, 0)
        If IsNumeric(lrIndex) Then
            sState = CStr(sData(r, 3))
            lcIndex = Application.Match(sState, lStates, 0)
            If IsNumeric(lcIndex) Then
                IsFound = True
            End If
        End If
        If IsFound Then
            sStock = sData(r, 4)
            dData(r, 1) = lPrices(lrIndex, lcIndex) * sStock
            IsFound = False
        Else
            dData(r, 1) = "Error"
        End If
    Next r

    srg.Columns(5).Value = dData
    
    MsgBox "Totals calculated.", vbInformation

End Sub

编辑：重构（字典）

主要

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Calculates totals...
' Calls:        GetJoinedColumnRanges
'                   GetSingleColumn
'               GetSingleColumn
'               DictJoinedTables
'               GetMultipliedUniques
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CalcTotals()

    Const WS_NAME As String = "Page 1"
    Const LKP_FIRST_CELL As String = "H1"
    Const SRC_FIRST_CELL As String = "A1"
    Dim sUniqueColumns(): sUniqueColumns = Array(2, 3)
    Const SRC_COUNT_COLUMN As Long = 4
    Const DST_COLUMN As Long = 5
    Const UNIQUE_DELIMITER As String = "@"
    Const NO_MATCH_STRING As String = "Error"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
    
    Dim rg As Range
    
    With ws.Range(SRC_FIRST_CELL).CurrentRegion
        Set rg = .Resize(.Rows.Count - 1).Offset(1)
    End With
    
    Dim suData():
    suData = GetJoinedColumnRanges(rg, sUniqueColumns, UNIQUE_DELIMITER)
    Dim scData(): scData = GetSingleColumn(rg, SRC_COUNT_COLUMN)
    
    Dim lrg As Range: Set lrg = ws.Range(LKP_FIRST_CELL).CurrentRegion
    Dim lDict As Object: Set lDict = DictJoinedTable(lrg, UNIQUE_DELIMITER)
        
    Dim dData():
    dData = GetMultipliedUniques(suData, scData, lDict, NO_MATCH_STRING)
    
    rg.Columns(DST_COLUMN).Value = dData
    
    MsgBox "Totals calculated.", vbInformation

End Sub

加入列范围

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the joined ('Delimiter') columns ('ColumnIndexes')
'               of a range ('rg') in a 2D one-based single-column array.
' Calls:        GetSingleColumn
' Date:         2023
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetJoinedColumnRanges( _
    ByVal rg As Range, _
    ByVal ColumnIndexes As Variant, _
    Optional ByVal Delimiter As String = " ") _
As Variant
    
    Dim LB As Long: LB = LBound(ColumnIndexes)
    
    Dim sData(), dData(), n As Long, r As Long, rCount As Long
    
    For n = LB To UBound(ColumnIndexes)
        If n = LB Then
            dData = GetSingleColumn(rg.Columns(ColumnIndexes(n)))
            rCount = UBound(dData, 1)
        Else
            sData = GetSingleColumn(rg.Columns(ColumnIndexes(n)))
            For r = 1 To rCount
                dData(r, 1) = dData(r, 1) & Delimiter & CStr(sData(r, 1))
            Next r
        End If
    Next n
    
    GetJoinedColumnRanges = dData

End Function

获取单列

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a column ('ColumnIndex')
'               of a range ('rg') in a 2D one-based single-column array.
' Date:         2023
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSingleColumn( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Variant
    
    Dim Data()
    
    With rg.Columns(ColumnIndex)
        If rg.Rows.Count = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With

    GetSingleColumn = Data

End Function

连接表到字典

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a table with the first column of row labels and the first
'               row of column labels, returns the joined label combinations
'               in the keys, and each associated value in the items
'               of a dictionary.
' Date:         2023
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictJoinedTable( _
    ByVal rg As Range, _
    Optional ByVal Delimiter As String = " ") _
As Object
    
    Dim Data(): Data = rg.Value
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim cCount As Long: cCount = rg.Columns.Count
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
   
    Dim r As Long, c As Long, kStr As String
   
    For r = 2 To rCount
        For c = 2 To cCount
            kStr = Data(r, 1) & Delimiter & Data(1, c)
            If Not dict.Exists(kStr) Then
                dict(kStr) = Data(r, c)
            End If
        Next c
    Next r
    
    If dict.Count > 0 Then
        Set DictJoinedTable = dict
    End If
    
End Function

获得成倍的独特性

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Looks for each value of a 2D one-based array ('UniqueData')
'               in the keys of a dictionary ('LookupDictionary') to return
'               the product of the associated item and the value in another
'               same-sized 2D one-based array ('MultiplyData') in the resulting
'               same-sized 2D one-based array. If not found, instead
'               of the product, a string ('NoMatchString') is returned.
' Date:         2023
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetMultipliedUniques( _
    ByVal UniqueData As Variant, _
    ByVal MultiplyData As Variant, _
    ByVal LookupDictionary As Object, _
    ByVal NoMatchString As String) _
As Variant
    
    Dim rCount As Long: rCount = UBound(MultiplyData, 1)
    
    Dim dData(): ReDim dData(1 To rCount, 1 To 1)
    
    Dim r As Long, sStr As String
    
    For r = 1 To rCount
        sStr = UniqueData(r, 1)
        If LookupDictionary.Exists(sStr) Then
            dData(r, 1) = LookupDictionary(sStr) * MultiplyData(r, 1)
        Else
            dData(r, 1) = NoMatchString
        End If
    Next r

    GetMultipliedUniques = dData

End Function
0
投票

在我看来，您的问题实际上是关于性能的（“它真的很慢”）。因此，无论何时处理大范围，都可以轻松显着提高性能：

  • 将输入范围复制到一个变体（它将成为一个二维数组）
  • 处理变体，将结果存储在输出变体中
  • 将输出变量复制到输出范围

要让 Excel 在范围/工作表和 VBA 之间来回切换，需要大量的 Windows 开销。此过程在每个方向进行一次行程，因此开销很小。每当我处理多个细胞时，我都会使用这个过程。请注意，您不需要将 

Dim
变体作为数组，因为变体可以容纳一个数组。但是您确实需要在写入之前
Redim
输出数组，这样您就可以像在任何其他数组中一样处理单个元素。

我怀疑@BigBen 是对的，这可能只用工作表公式就可以完成，但我认为这个“范围到变体和回到范围”的过程值得理解。警告：当复制的输入范围是单个单元格时，变量是标量。在这种情况下尝试使用数组表示法访问它会产生错误。

这是一种方法：

Sub Calculate()  ' Can't use Go() because Go is an Excel keyword
    ' It's good practice to Dim all variables
    Dim Page1 As Worksheet, LastRow As Long, i As Long, vntContent As Variant, vntOutput As Variant
    Dim vntPrices As Variant, nPriceRow As Integer, nPriceCol As Integer, rngData As Range
    
    ' Count the rows
    Set Page1 = Worksheets("Sheet6")
    LastRow = Page1.Cells(Page1.Rows.Count, "A").End(xlUp).Row
    
    Set rngData = Page1.Cells(1, 8).Resize(3, 3)  ' Price table
    vntPrices = rngData
    
    Set rngData = Page1.Cells(1, 1).Resize(LastRow, 4)  ' Input range
    vntContent = rngData
    ReDim vntOutput(1 To LastRow, 1 To 1)
    
    For i = 2 To LastRow
        ' Determine the price lookup column
        Select Case vntContent(i, 3)
            Case "good"
                nPriceCol = 2
            Case "bad"
                nPriceCol = 3
            Case Else
                nPriceCol = 0
        End Select
        
        ' Determine the price lookup row
        Select Case vntContent(i, 2)
            Case "fruit"
                nPriceRow = 2
            Case "salad"
                nPriceRow = 3
            Case Else
                nPriceRow = 0
        End Select
        
        ' If both are valid, calculate price * stock
        If nPriceRow > 0 And nPriceCol > 0 Then
            vntOutput(i, 1) = vntPrices(nPriceRow, nPriceCol) * vntContent(i, 4)
        Else
            vntOutput(i, 1) = "Error"
        End If
    Next i
    
    ' Write the output to the P*S column
    Set rngData = Page1.Cells(1, 5).Resize(LastRow, 1)
    rngData = vntOutput
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.