VBA：用于交叉工作表操作的速度非常慢的宏（7k行需要15分钟！）_Vba_Excel

VBA：用于交叉工作表操作的速度非常慢的宏（7k行需要15分钟！）

vba excel

VBA：用于交叉工作表操作的速度非常慢的宏（7k行需要15分钟！）,vba,excel,Vba,Excel,我有一个excel文件，有两张表格，分别是：材料表和结果表，其中后者是结果的空表。在物料表中我有物料信息和移动代码。至于模式：列A有物料代码，列G有移动代码现在，对于每种材料，可能有多行具有不同于移动代码集（101102201202241242261262561）的移动代码。我需要检查并应用以下逻辑：从材料表复制材料的所有行并粘贴结果表“”，如果（此材料的202计数>=此材料的201计数）和（此材料的242计数>=此材料的241计数）和（此材料的262计数>=此材料的261计数）目前

我有一个excel文件，有两张表格，分别是：<代码>材料表和

结果表

，其中后者是结果的空表。在

物料表中

我有物料信息和移动代码。至于模式：

列A有物料代码，列G有移动代码

现在，对于每种材料，可能有多行具有不同于移动代码集（101102201202241242261262561）的移动代码。我需要检查并应用以下逻辑：

从

材料表

复制材料的所有行并粘贴结果表“”，
如果（此材料的202计数>=此材料的201计数）和（此材料的242计数>=此材料的241计数）和（此材料的262计数>=此材料的261计数）

目前，我有以下代码（文章末尾）。在此过程中，它过滤有效的物料代码并将这些代码存储在结果表中（还不是整行！）

我想要的是：

我需要修改它，这样每个过滤材料的所有_行都应该复制到结果表中

对于约7000个值，现有代码的执行时间太长（如15分钟）。太慢了 FilterWart移动是主要的驱动程序例程。它调用collectionUniqueMaterials函数将唯一的材质从columnA收集到collectionUniqueMaterials数组。然后，对于每个独特的材料，它从材料表的g列收集移动代码，并在FilterValues函数中检查上述逻辑

Sub FilterWRTMovement()
    Application.ScreenUpdating = False
    Dim collectionUniqueMaterials() As String
    Dim LRow As Long, counter1 As Long, counter2 As Long
        Dim result(10000) As String, movementOfOneMaterial() As String, current As String
    Dim has202 As Boolean, has242 As Boolean, has262 As Boolean
    Dim Destination As Worksheet

    LRow = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
    c = collectUniqueMaterials(collectionUniqueMaterials, LRow)
    counter1 = 0
    counter2 = 0
    Set Destination = Worksheets("Resultant Sheet")

    With ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & LRow)
        .EntireRow.Hidden = False
        For Each i In collectionUniqueMaterials
            i = Trim(i)
            ReDim movementOfOneMaterial(200) As String
            has202 = True
            has242 = True
            has262 = True
            counter1 = 0

            For j = 1 To .Rows.Count
                current = Trim(Cells(j, 1))
                If current = i Then
                    movementOfOneMaterial(counter1) = Cells(j, 7)
                    counter1 = counter1 + 1
                End If
            Next j

            FilterValues movementOfOneMaterial, has202, has242, has262
            If has202 = True And has242 = True And has262 = True Then
                result(counter2) = i
                counter2 = counter2 + 1
            End If
            Erase movementOfOneMaterial
        Next i
    End With
    Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result)

    'For Each tup In result
    'FindMe (tup)
    'Next tup
End Sub

Function collectUniqueMaterials(ByRef collection() As String, ByRef last As Long)
    Dim tmp As String

    myselect = ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & last)
    For Each cell In myselect
        If (cell <> "") And (InStr(tmp, cell) = 0) Then
            tmp = tmp & cell & "|"
        End If
    Next cell

    If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
    collection = Split(tmp, "|")
End Function



Function FilterValues(ByRef sarrCodes() As String, ByRef has202 As Boolean, ByRef has242 As Boolean, ByRef has262 As Boolean)
    Dim a As Long
    Dim vKey As Variant
    Dim objDic As Object


    Set objDic = CreateObject("Scripting.Dictionary")

    For a = LBound(sarrCodes) To UBound(sarrCodes)
        If objDic.Exists(sarrCodes(a)) Then
            objDic.Item(sarrCodes(a)) = objDic.Item(sarrCodes(a)) + 1
        Else
            objDic.Add sarrCodes(a), 1
        End If
    Next a

    If objDic.Exists("201") And objDic.Item("201") <> "" Then
        has202 = False
        If objDic.Exists("202") And objDic.Item("202") <> "" And objDic.Item("202") >= objDic.Item("201") Then
            has202 = True
        End If
    ElseIf objDic.Exists("241") And objDic.Item("241") <> "" Then
        has242 = False
        If objDic.Exists("242") And objDic.Item("242") <> "" And objDic.Item("242") >= objDic.Item("241") Then
            has242 = True
        End If
    ElseIf objDic.Exists("261") And objDic.Item("261") <> "" Then
        has262 = False
        If objDic.Exists("262") And objDic.Item("262") <> "" And objDic.Item("262") >= objDic.Item("261") Then
            has262 = True
        End If
    End If
End Function

现在，不是将唯一的物料代码保存在结果表中（

Destination.Range（“A1”）.Resize（10000，1）.Value=Application.Transpose（result）

），而是根据

result

数组的每个值从“物料集”复制所有行的优化方法是什么（给定：对于结果元素的每个值，物料表中有多行。我希望所有行都得到过滤后的数据）

更新在Tim的帖子中稍加调整，我就能在一秒钟内达到预期效果。以下是VBA脚本：

Sub FilterMaterialWRTMovement()

    Const SourceSheet As String = "Material Sheet"
    Const DestinationSheet As String = "Resultant Sheet"

    Const COL_ID As Integer = 1
    Const COL_MOVE As Integer = 7

    Dim dict As Object
    Dim data As Variant, data2(), numRows As Long, numCols As Long
    Dim r As Long, c As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim id, mv, arrMv, pos, tmp
    Dim data2Row As Long
    Dim firstPass As Boolean

     Set dict = CreateObject("Scripting.Dictionary")
        'movement codes to count
        arrMv = Array(201, 202, 241, 242, 261, 262)

        Set shtSrc = ActiveWorkbook.Sheets(SourceSheet)
        Set shtDest = ActiveWorkbook.Sheets(DestinationSheet)

        shtDest.Cells.Clear

        data = shtSrc.Range(shtSrc.Range("A2"), _
               shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 10)).Value

        numRows = UBound(data, 1)
        numCols = UBound(data, 2)

        ReDim data2(1 To numRows, 1 To numCols)

        data2Row = 1
        firstPass = True

runAgain:
        For r = 1 To numRows
            id = data(r, COL_ID)

            If firstPass Then
                'collecting counts...
                mv = data(r, COL_MOVE)
                If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0)
                pos = Application.Match(mv, arrMv, 0)
                If Not IsError(pos) Then
                    tmp = dict(id)
                    If id = 7024113 Then
                    cwe = 1
                    End If
                    tmp(pos - 1) = tmp(pos - 1) + 1
                    dict(id) = tmp
                End If
                'firstPass = False
            Else
                'copying rows
                tmp = dict(id)
                If (tmp(0) <> 0) Or (tmp(2) <> 0) Or (tmp(4) <> 0) Then
                    If Not ((tmp(0) <> 0 And tmp(1) < tmp(0)) Or (tmp(2) <> 0 And tmp(3) < tmp(2)) Or (tmp(4) <> 0 And tmp(5) < tmp(4))) Then
                        For c = 1 To numCols
                            data2(data2Row, c) = data(r, c)
                        Next c
                        data2Row = data2Row + 1
                    End If
                End If
            End If
        Next r

        If firstPass Then
            Beep
            firstPass = False
            GoTo runAgain
        Else
            shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2
        End If

End Sub

子过滤器材料移动（）
Const SourceSheet As String=“物料表”
Const DestinationSheet As String=“结果表”
常量列ID为整数=1
常量COL_移动为整数=7
作为对象的Dim dict
Dim数据作为变量，data2（），numRows作为长，numCols作为长
变暗r为长，c为长
尺寸shtSrc作为工作表，shtDest作为工作表
仪表板id、mv、arrMv、pos、tmp
变暗数据2尽可能长
Dim firstPass作为布尔值
Set dict=CreateObject（“Scripting.Dictionary”）
'要计数的移动代码
arrMv=阵列（20120224124261262）
设置shtSrc=ActiveWorkbook.Sheets（SourceSheet）
Set shtDest=ActiveWorkbook.Sheets（目的表）
shtDest.Cells.Clear
数据=shtSrc.范围（shtSrc.范围（“A2”）_
shtSrc.Cells（Rows.Count，1）.End（xlUp）.Offset（0，10））.Value
numRows=UBound（数据，1）
numCols=UBound（数据，2）
ReDim数据2（1到numRows，1到numCols）
data2Row=1
firstPass=True
再次运行：
对于r=1到numRows
id=数据（r，COL\u id）
如果第一次通过的话
“收集计数。。。
mv=数据（r，COL_移动）
如果不存在dict.Exists（id），则dict.Add id，数组（0,0,0,0,0）
位置=应用程序匹配（mv、arrMv、0）
如果不是IsError（pos），则
tmp=dict（id）
如果id=7024113，则
cwe=1
如果结束
tmp（位置1）=tmp（位置1）+1
dict（id）=tmp
如果结束
'firstPass=False
其他的
'复制行
tmp=dict（id）
如果（tmp（0）0）或（tmp（2）0）或（tmp（4）0），则
如果不是（（tmp（0）0和tmp（1）


谢谢大家！
这是哪个版本的Excel？如果是2007年或2010年，罪魁祸首可能是j=1到.Rows.Count的，处理大量不必要的单元格。

您可以尝试使用

范围内的每个c（“a:a”）。特殊单元格（xlCellTypeConstants）
相反。
它是哪个版本的Excel？如果是2007或2010，罪魁祸首可能是j=1到.Rows.Count的，处理大量不必要的单元格。

您可以尝试使用

范围内的每个c（“a:a”）。特殊单元格（xlCellTypeConstants）
相反。
两个观察结果：
（正如iDevelop提到的那样，.Rows.Count会增加很多不必要的开销。另外，LRow不是已经设置为最后一个行号了吗
另外，如果我正确地阅读了代码，您将值添加到数组中，然后在FilterValues子项中对它们进行计数。难道不可能将它们添加到字典中，并在一次传递中递增它们，而不是使用嵌套循环并调用FilterValues吗？
两个观察结果：
（正如iDevelop提到的那样，.Rows.Count会增加很多不必要的开销。另外，LRow不是已经设置为最后一个行号了吗
另外，如果我正确地读取了代码，那么就是将值添加到数组中，然后在FilterVa中对它们进行计数
Sub FilterMaterialWRTMovement()

    Const SourceSheet As String = "Material Sheet"
    Const DestinationSheet As String = "Resultant Sheet"

    Const COL_ID As Integer = 1
    Const COL_MOVE As Integer = 7

    Dim dict As Object
    Dim data As Variant, data2(), numRows As Long, numCols As Long
    Dim r As Long, c As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim id, mv, arrMv, pos, tmp
    Dim data2Row As Long
    Dim firstPass As Boolean

     Set dict = CreateObject("Scripting.Dictionary")
        'movement codes to count
        arrMv = Array(201, 202, 241, 242, 261, 262)

        Set shtSrc = ActiveWorkbook.Sheets(SourceSheet)
        Set shtDest = ActiveWorkbook.Sheets(DestinationSheet)

        shtDest.Cells.Clear

        data = shtSrc.Range(shtSrc.Range("A2"), _
               shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 10)).Value

        numRows = UBound(data, 1)
        numCols = UBound(data, 2)

        ReDim data2(1 To numRows, 1 To numCols)

        data2Row = 1
        firstPass = True

runAgain:
        For r = 1 To numRows
            id = data(r, COL_ID)

            If firstPass Then
                'collecting counts...
                mv = data(r, COL_MOVE)
                If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0)
                pos = Application.Match(mv, arrMv, 0)
                If Not IsError(pos) Then
                    tmp = dict(id)
                    If id = 7024113 Then
                    cwe = 1
                    End If
                    tmp(pos - 1) = tmp(pos - 1) + 1
                    dict(id) = tmp
                End If
                'firstPass = False
            Else
                'copying rows
                tmp = dict(id)
                If (tmp(0) <> 0) Or (tmp(2) <> 0) Or (tmp(4) <> 0) Then
                    If Not ((tmp(0) <> 0 And tmp(1) < tmp(0)) Or (tmp(2) <> 0 And tmp(3) < tmp(2)) Or (tmp(4) <> 0 And tmp(5) < tmp(4))) Then
                        For c = 1 To numCols
                            data2(data2Row, c) = data(r, c)
                        Next c
                        data2Row = data2Row + 1
                    End If
                End If
            End If
        Next r

        If firstPass Then
            Beep
            firstPass = False
            GoTo runAgain
        Else
            shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2
        End If

End Sub

Sub FilterAndCopyRows()

Const COL_ID As Integer = 1
Const COL_MOVE As Integer = 7

Dim dict As New Scripting.dictionary
Dim data As Variant, data2(), numRows As Long, numCols As Long
Dim r As Long, c As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim id, mv, arrMv, pos, tmp
Dim data2Row As Long
Dim firstPass As Boolean

    'movement codes to count
    arrMv = Array(201, 202, 241, 242, 261, 262)

    Set shtSrc = ActiveWorkbook.Sheets("Material Sheet")
    Set shtDest = ActiveWorkbook.Sheets("Resultant Sheet")

    data = shtSrc.Range(shtSrc.Range("A2"), _
           shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 6)).Value

    numRows = UBound(data, 1)
    numCols = UBound(data, 2)

    ReDim data2(1 To numRows, 1 To 7)

    data2Row = 1
    firstPass = True

runAgain:
    For r = 1 To numRows
        id = data(r, COL_ID)

        If firstPass Then
            'collecting counts...
            mv = data(r, COL_MOVE)
            If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0)
            pos = Application.Match(mv, arrMv)
            If Not IsError(pos) Then
                tmp = dict(id)
                tmp(pos - 1) = tmp(pos - 1) + 1
                dict(id) = tmp
            End If
        Else
            'copying rows
            tmp = dict(id)
            If (tmp(1) > tmp(0)) And (tmp(3) > tmp(2)) And (tmp(5) > tmp(4)) Then
                For c = 1 To numCols
                    data2(data2Row, c) = data(r, c)
                Next c
                data2Row = data2Row + 1
            End If
        End If
    Next r

    If firstPass Then
        Beep
        firstPass = False
        GoTo runAgain
    Else
        shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2
    End If

End Sub

Application.Calculation = xlCalculationManual 'turn off the automatic calc
  'your code goes here
Application.Calculation = xlCalculationAutomatic 'turn On the automatic calc

if a = "" or a = "" 'thats not good way to do