时间戳

首页 > 解决方案 > 循环优化以逃避硬编码

excel - 循环优化以逃避硬编码

问题描述

我有 5 张桌子。在每张桌子上，如果我选中一个复选框，他们将自动选中以下所有复选框。如果我取消选中该复选框，它将取消选中以下所有复选框。我写了一些适用于一张桌子的东西，但我不想为每个不同的桌子/范围复制这段代码。有没有办法优化这段代码，所以我不必为所有实例硬编码

Sub SelectAll_Click()
    Dim rng As Range, cell As Range
    
    If Range("A17") = TRUE Then
        For Each cell In Range("B19:B28")
            cell.Value = TRUE
            Cells(cell.Row, "F").Value = Now
            Cells(cell.Row, "G").Value = VBA.Environ("Username")
        Next cell
    Else
        For Each cell In Range("B19:B28")
            cell.Value = FALSE
            Cells(cell.Row, "F").ClearContents
            Cells(cell.Row, "G").ClearContents
        Next cell
    End If
End Sub

示例：红色：“cochez si non requis”是法语的“检查是否不需要” 在此处输入图像描述

编辑：

我尝试了@chris neilsen 的回答 - 它正在工作，但响应时间太慢了。我觉得它没有优化......这是最终代码：

Sub SelectAll(rCheck As Range, rUpdate As Range, colTime As Long, colUser As Long)
    Dim cell        As Range
    
    If rCheck = TRUE Then
        Sheets("Sheet2").Unprotect Password:="abc"
        For Each cell In rUpdate
            cell.Value = TRUE
            cell.EntireRow.Cells(1, colTime).Value = Now
            cell.EntireRow.Cells(1, colUser).Value = VBA.Environ("Username")
        Next cell
    Else
        For Each cell In rUpdate
            Sheets("Sheet2").Unprotect Password:="abc"
            cell.Value = FALSE
            cell.EntireRow.Cells(1, colTime).ClearContents
            cell.EntireRow.Cells(1, colUser).ClearContents
        Next cell
    End If
    Sheets("Sheet2").Protect Password:="abc"
End Sub

Sub SelectAll_Click()
    SelectAll Range("A17"), Range("B19:B28"), 6, 7
    SelectAll Range("A31"), Range("B33:B35"), 6, 7
    SelectAll Range("A38"), Range("B40:B41"), 6, 7
    SelectAll Range("A45"), Range("B46:B49"), 6, 7
    SelectAll Range("A52"), Range("B54:B62"), 6, 7
    SelectAll Range("A66"), Range("B67:B72"), 6, 7
    SelectAll Range("A75"), Range("B77:B83"), 6, 7
    SelectAll Range("A86"), Range("B88:B89"), 6, 7
End Sub

标签： excelvba

解决方案

通过添加一些参数来概括您的 Sub。

Sub SelectAll(rCheck As Range, rUpdate As Range, colTime As Long, colUser As Long)
    Dim cell As Range
    
    If rCheck = TRUE Then
        For Each cell In rUpdate 
            cell.Value = TRUE
            cell.EntireRow.Cells(1, colTime).Value = Now
            cell.EntireRow.Cells(1, colUser).Value = VBA.Environ("Username")
        Next cell
    Else
        For Each cell In rUpdate 
            cell.Value = FALSE
            cell.EntireRow.Cells(1, colTime).ClearContents
            cell.EntireRow.Cells(1, colUser).ClearContents
        Next cell
    End If
End Sub

在 Click 事件中调用它，传递所需的参数

Sub SelectAll_Click()
    SelectAll Range("A17"), Range("B19:B28"), 6, 7
End Sub

上面的答案解决了最初的问题：有没有办法优化这段代码，所以我不必为所有实例硬编码

为了还解决优化速度问题，请考虑这一点


Sub SelectAll_Click()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Sheet2").Unprotect Password:="abc"

    SelectAll Range("A17"), Range("B19:B28"), 6, 7
    SelectAll Range("A31"), Range("B33:B35"), 6, 7
    SelectAll Range("A38"), Range("B40:B41"), 6, 7
    SelectAll Range("A45"), Range("B46:B49"), 6, 7
    SelectAll Range("A52"), Range("B54:B62"), 6, 7
    SelectAll Range("A66"), Range("B67:B72"), 6, 7
    SelectAll Range("A75"), Range("B77:B83"), 6, 7
    SelectAll Range("A86"), Range("B88:B89"), 6, 7

    Application.ScreenUpdating = TRUE
    Application.Calculation = xlCalculationAutomatic
    Sheets("Sheet2").Protect Password:="abc"
End Sub

Sub SelectAll(rCheck As Range, rUpdate As Range, colTime As Long, colUser As Long)
    If rCheck = TRUE Then
        rUpdate.Value = TRUE
        rUpdate.EntireRow.Columns(colTime).Value = Now
        rUpdate.EntireRow.Columns(colUser).Value = VBA.Environ("Username")
    Else
        rUpdate.Value = FALSE
        rUpdate.EntireRow.Columns(colTime).ClearContents
        rUpdate.EntireRow.Columns(colUser).ClearContents
    End If
End Sub

推荐阅读