Question

我拥有的代码会扫描匹配项并执行几项操作：

首先，它检查约会日期是否在测试请求日期之后。
然后，通过确保请求的确切代码在那里（有6列用于测试的代码）来确保请求的单元格不为空。
然后，确保请求和约会的帐号相同。

以下是几个条件：

如果在请求日期或之后与所请求的服务进行了约会，则该约会将不执行任何操作并移至下一行。
如果缺少所请求服务的约会，则应突出显示黄色单元格。
如果工作表C上的请求插槽为空白，则该代码不应执行任何操作。
如果请求空位已满，但在请求日期或之后有一个约会，对于相同的帐户编号，并且请求类型/约会类型匹配，该代码将不执行任何操作。
如果没有，则请求行应以黄色突出显示。

问题

除了用红色突出显示我可以处理的代码外，该代码似乎还突出显示了所有行，而不是仅突出显示了已请求服务但缺少约会的行。

请求工作表为C，所有预定约会工作表为B。一个不错的办法是将For循环限制为仅包含数据的行，以使处理更快地完成（也许添加一个进度栏吗？Excel和VBA窗口都没有响应，但机器风扇运行得更快，所以我知道它肯定在做某事。

数据

使事情变得简单一些：

在工作表C（请求表）上：

Account # = Column A

Request Date = Column G

Request Type = Columns H-M

在工作表B（主工作表）上：

Account # = Column A (Must match Sheet C Column A)

Appointment Date = Column L (Must be >= (Greater or equal) to Sheet C Column G

Appointment Type = Column P (Must match Sheet C Column H-M)

代码

Sub check_for_copies()

Dim i As Long
Dim j As Long

For j = 2 To 1000

For i = 2 To 10000

    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 8).Value = "CR15" And Sheets("C").Cells(j, 8).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 8).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If


    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 9).Value = "TR15" And Sheets("C").Cells(j, 9).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 9).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If

    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 10).Value = "EEG60" And Sheets("C").Cells(j, 10).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 10).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If


    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 11).Value = "EMG15" And Sheets("C").Cells(j, 11).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 11).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If


    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 12).Value = "NV30" And Sheets("C").Cells(j, 12).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 12).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If


    If Sheets("C").Cells(j, 7).Value <= Sheets("B").Cells(i, 12).Value And Sheets("C").Cells(j, 1).Value = Sheets("B").Cells(i, 1).Value And Sheets("C").Cells(j, 13).Value = "NV45" And Sheets("C").Cells(j, 13).Value = Sheets("B").Cells(i, 16).Value Then
        'do nothing
    ElseIf Sheets("C").Cells(j, 13).Value = "" Then
        'do nothing
    Else
        Sheets("C").Rows(j).Interior.ColorIndex = 3
    End If

Next

Next

End Sub

该代码非常缓慢，看起来好像崩溃了excel。我尝试添加

Application.Calculation = false
Application.ScreenUpdating = false
Application.EnableEvents = false

但这似乎无济于事！

Answer 1

请考虑避免嵌套For循环并运行基于集合的操作（例如关系数据库中的表）或运行分析工具（例如SAS，SPSS，Stata，Python's Pandas，R，Julia和其他。这使您可以按帐号和请求类型合并或连接这两套数据，并且比迭代循环更有效地运行任何矢量化列操作。但是，您可以运行Excel的INDEX...MATCH，但需要数组或数组公式进行条件日期比较和缺少值。

幸运的是，如果您使用Windows的Excel，则可以与JET / ACE SQL引擎（.dll文件）交互，在其中可以合并两张工作簿并创建所需的列作为突出显示的指示器。注意：由于Excel不是数据库，因此不符合数据完整性规则，因此请务必以单一数据类型（无混合类型）设置每一列的格式，尤其是将日期列设置为实际日期或留空，否则下面的逻辑将不会工作。

SQL （将If条件转换为嵌套在其他RDBMS中的IIF或CASE）

根据需要调整实际的列和工作表名称。

SELECT c.*, b.*, 
       IIF((b.[Appointment Date] >= c.[Request Date]) OR (c.[Request Date] IS NULL), 0,
           IIF(b.[Appointment Date] IS NULL, 1,
               IIF((b.[Appointment Date] < c.[Request Date]), 1, 0)
               )
           ) AS [highlight]                      
FROM [SheetC$] c
INNER JOIN [SheetB$] b
   ON c.[Account #] = b.[Account #] AND c.[Request Type] = b.[Appointment Type]

或者在理想情况下，将两张表导入实际的数据库（或上述分析工具）中，例如Excel的同级，MS Access，然后运行相同的SQL查询，并将Access转储结果返回到Excel中以突出显示，或者保留在Access中并运行conditional formatting在表单或报表上！

VBA （在查询上方运行，并将查询输出转储到现有的空白结果工作表中）

在结果表中将计算出的突出显示行（值为0或1）用于黄色行突出显示。

Sub RunSQL()    
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    ' CONNECTION STRINGS (DRIVER VERSION COMMENTED OUT)
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=C:\Path\To\Workbook.xlsm;"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='C:\Path\To\Workbook.xlsm';" _
                       & "Extended Properties=""Excel 12.0;HDR=YES;"";"

    strSQL = "SELECT c.*, b.*, " _
           &  "     IIF((b.[Appointment Date] >= c.[Request Date]) OR (c.[Request Date] IS NULL), 0, " _
           &  "         IIF(b.[Appointment Date] IS NULL, 1, " _
           &  "             IIF((b.[Appointment Date] < c.[Request Date]), 1, 0) " _
           &  "             ) " _
           &  "        ) AS [highlight]  " _                     
           &  " FROM [SheetC$] c " _
           &  " INNER JOIN [SheetB$] b " _
           &  "    ON c.[Account #] = b.[Account #] AND c.[Request Type] = b.[Appointment Type]"  

    ' OPEN CONNECTION
    conn.Open strConnection
    rst.Open strSQL, conn

    ' COLUMN HEADERS
    With Worksheet("Results")
        For i = 1 To rst.Fields.Count - 1
           .Cells(1, i) = rst.Fields(i).Name
        Next i        
       ' DATA ROWS
       .Range("A2").CopyFromRecordset rst
    End With

    rst.Close: conn.Close    
    Set rst = Nothing: Set conn = Nothing
End Sub

Nested For Loop的运行速度很慢，无法正常工作

1 个答案: