帶有下拉列表的 VBA Excel 2013 列范圍，用於創建 VBA 代碼以選擇所有和取消選擇所有復選標記

Question

我是 vba 新手，需要幫助。 目前，我在特定列 (E1:E519) 中有一個下拉列表，工作人員可以在其中選擇復選標記或將其留空。 但是，如果某人有 400 人左右的復選框，這可能會很煩人。 所以這促使我使用 vba 在側面創建一個命令按鈕來選擇和取消選擇該特定列范圍內的所有內容。

如何創建僅允許檢查填充具有下拉列表選項的單元格中選定范圍內的空白的 vba 代碼（下拉列表中只有 1 個選項，這是一個復選標記）。 對於喜歡單獨選中每個框而不使用命令按鈕的用戶，必須保留下拉列表。 E 列要么得到支票，要么留空。 如果它認識到如果 B 列有數據，那么應該在同一行的 E 列中添加一個復選標記，這會容易得多。 如果有代碼，我肯定會感謝我能得到的所有幫助。 我使用的確切復選標記是帶有子集 Dingbat 字符代碼 2713 的 Arial Unicode MS 字體。

有人可以幫助我並告訴我如何正確地做到這一點嗎？ 我也很感激一些解釋，以便我可以理解代碼語言並進一步學習。 謝謝！

我正在使用的當前代碼（顯示“？”而不是位於單元格 E14（第 14 行，第 5 列）中的復選標記）：

Private Sub CommandButton1_Click()

Dim c As Range
Dim check As Long

check = 0 'Define 0 for crossmark or 1 for checkmark

For Each c In Range("E17:E519") 'Define your range which should look value not equal to 1, then loop through that range.
If c <> 1 Then 'check if value in range is not equal to 1
With c 'Define what you want to do with variable c
    If check = 1 Then 'If check = 1, then
        .Font.Name = "Arial Unicode MS" 'Apply font "Arial Unicode MS"
        .Font.Size = 12 'Font size
        .FormulaR1C1 = "ü" 'special character for checkmark
    ElseIf check = 0 Then 'If cehck = 1, then
        .Font.Name = "Arial Unicode MS" 'Apply font "Arial Unicode MS"
        .Font.Size = 12 'Font size
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .FormulaR1C1 = "?"
End If
End With
End If
Next c
End Sub

下一個代碼

Sub change_cells_ref2()
        Dim ws As Worksheet
        Dim c As Range
        Dim c_row_number As Long
        Dim rangeinput As Variant

    Set ws = Worksheets("NFLES ILT Form") 'Define the worksheet the code should be applied to
Application.ScreenUpdating = False 'Turn off screen update, makes the calculations more smooth and faster.

Set rangeinput = Range("E17:E519") 'Set Range where you want to check if the variable c is empty. If you have headers, set "B2:B519"

For Each c In rangeinput 'This line defines your range where you are looking for "", then loop through that range.
c_row_number = c.Row 'Gives us the current row number for the loop variable c which we are looping.
    If c <> "" Then 'Checks if the value in variable c is empty
        ws.Cells(14, "E").Copy 'Copy from cell(14,5) where cells(row number, column number). This will copy row 14, column 5, which is cell E14
        ws.Cells(c_row_number, "E").PasteSpecial xlPasteAll 'Paste into current row in loop and column 5 (column E)
    End If 'End the if statement where we check which value variable c has.
Next c 'Go to next c in the range

Application.CutCopyMode = False 'Cancel any copy selection
Application.ScreenUpdating = True 'Turn off screen update

End Sub

Answer 1

這里棘手的部分是您為 crossmark/ticker 使用了什么樣的字符。 所以我列出了兩種方法，這是我之前使用過的第一種方法。
因為我希望它在宏和下拉列表中都被標准化，所以我在單元格B1和B2選擇一個字符集作為虛擬變量。

B1 = 復選標記 (✓) = 1和B2 = 十字標記 (✗) = 0 。 最大的好處是我可以在下拉列表（見圖）和 VBA 代碼中使用相同的字符。 請注意，我的單元格B1和B2都有下拉列表。 當我的代碼復制這些單元格時，下拉列表將跟隨到新單元格。

當我運行代碼時，我首先需要選擇1或0 。 您選擇的內容取決於代碼是復制復選標記（值為1 ）還是交叉標記（值為0 ）。

下一個窗口是您定義范圍的地方。 您可以將其編寫為： E20:E50 ，也可以通過鼠標選擇來選擇它。

然后代碼處理，結果將改變單元格：

VBA 代碼：

Sub change_cells_ref()
Dim c As Range
Dim check_or_cross As Variant
Dim c_row_number As Long
Dim rangeinput As Variant

check_or_cross = Application.InputBox("Enter ""1"" for checkmark or ""0"" for crossmark") 'Input box for checkmarks (enter: 1) or crossmarks (enter: 0)
On Error Resume Next 'If error occurs, this is not a good way to mask errors... but if you press cancel in the inputbox when you are setting a range, VBA automatically throws an error: 13 before we can catch it, so we mask any errors that can occurs.
Set rangeinput = Application.InputBox(prompt:="Select range or Enter range, i.e. E17:E150", Type:=8) ' Input box for Range, Type:=8 tells us that the value has to be in range format. You could either select or write range.

For Each c In rangeinput 'Range("E17:E150") - remove "rangeinput" to have a static range. This line defines your range where you are look for "zxyx", then loop through that range.
    c_row_number = c.Row 'Gives us the current row for the loop variable c which we are looping.
        If c <> "zxyz" Then 'Checks if the value is combination that is very unlikely to occur. It will overwrite all those values that are not "zxyz".
        'If you replace the above code line with [If c = "" Then] the code would only overwrite cells that has not checkmark or crossmark...i,e only empty cells, could be good if you have some workers who answered, and some that hasn't. And only want to fill in those who didn't answer quickly.
            With c 'Define what you want to do with the variable c
                If check_or_cross = 1 Then 'If the user wrote 1, then copy checkmarks
                    .Font.Name = "Times New Roman" 'Set font that you want to use, remember all fonts doesn't support special characters/crossmark/checkmarks
                    .Font.Size = 12 'Set the Font size
                    Cells(1, 2).Copy 'Copy from cell(1,2) where cells(row number, column number). This will copy row 1, column 2, which is cell B1
                    Cells(c_row_number, 5).PasteSpecial xlPasteAll 'Paste into current row in loop and column 5 (column E)
                ElseIf check_or_cross = 0 Then 'If the user wrote 0, then copy crossmarks
                    .Font.Name = "Times New Roman" 'Set font that you want to use, remember all fonts doesn't support special characters/crossmark/checkmarks
                    .Font.Size = 12 'Set the Font size
                    Cells(2, 2).Copy 'Copy from cell(2,2) where cells(row number, column number). This will copy row 2, column 2, which is cell B2
                    Cells(c_row_number, 5).PasteSpecial xlPasteAll 'Paste into current row in loop and column 5 (column E)
                End If 'End the if statement (if check_or_cross is 1 or 0)
            End With 'Close the With c part
        End If 'End the if statement where we check which value c has.
Next c 'Go to next c in the range
On Error GoTo 0
End Sub

---

如果您總是想要一個靜態范圍並跳過范圍部分的輸入框，您可以刪除以下 3 行：

On Error Resume Next
Set rangeinput = Application.InputBox(prompt:="Select range or Enter range, i.e. E17:E150", Type:=8) 
'...code....
On Error GoTo 0

然后替換這部分For Each c In rangeinput -> For Each c In Range("E17:E517") - 其中E17:E517是您要更改復選標記/交叉標記的范圍

---

---

替代方法：

此代碼使用字體大小“Wingding”。

這里的缺點是您無法在下拉列表中以“好”的方式使用此樣式。 您將有值“ü”= ✓ 和 û = ✗。 這意味着在下拉列表中您將擁有 u's，但在宏中，它會在顯示結果時顯示正確的值。

優點是您不需要任何虛擬單元格，因為代碼不會復制任何單元格。 它直接從代碼中寫入值。 如果您有只想使用宏而沒有下拉列表的情況，這可能是一種完美的方法。

Sub change_cells()
Dim c As Range
Dim check As Long

check = 0 'Define 0 for crossmark or 1 for checkmark

For Each c In Range("E17:E150") 'Define your range which should look value not equal to 1, then loop through that range.
    If c <> 1 Then 'check if value in range is not equal to 1
    With c 'Define what you want to do with variable c
        If check = 1 Then 'If cehck = 1, then
            .Font.Name = "Wingdings" 'Apply font "Wingdings"
            .Font.Size = 12 'Font size
            .FormulaR1C1 = "ü" 'special character for checkmark
        ElseIf check = 0 Then 'If cehck = 1, then
            .Font.Name = "Wingdings" 'Apply font "Wingdings"
            .Font.Size = 12 'Font size
            .FormulaR1C1 = " û " 'special character for crossmark
        End If
    End With
End If
Next c
End Sub

---

---

---

下面的結果顯示了另一種簡單的方法：

代碼將查看 B 列中的單元格是否不為空。 如果單元格不為空（返回的公式： ""被視為空），它將從虛擬單元格A1復制值並粘貼到同一行的 E 列中。

注意設置帶有數據驗證和復選標記 ✓ 的虛擬單元格。 原因是字符 2713 是一個特殊字符，在 VBA 中它會導致“？” 特點。 因此我們將其復制到excel環境中可以正確處理包括下拉列表

代碼集中的變量：

• 工作表名稱，預定義為： "Sheet1"

• 查找數據的范圍： "B1:B519"

• ws.Cells(1, "A").Copy - 虛擬變量所在的單元格 ("A1")。

• ws.Cells(c_row_number, "E").PasteSpecial xlPasteAll - 設置應粘貼復選標記的列。

VBA 代碼：

Sub change_cells_ref2()
Dim ws As Worksheet
Dim c As Range
Dim c_row_number As Long
Dim rangeinput As Variant

Set ws = Worksheets("Sheet1") 'Define the worksheet the code should be applied to
Application.ScreenUpdating = False 'Turn off screen update, makes the calculations more smooth and faster.

Set rangeinput = Range("B1:B519") 'Set Range where you want to check if the variable c is empty. If you have headers, set "B2:B519"

For Each c In rangeinput 'This line defines your range where you are looking for "", then loop through that range.
    c_row_number = c.Row 'Gives us the current row number for the loop variable c which we are looping.
        If c <> "" Then 'Checks if the value in variable c is empty
            ws.Cells(1, "A").Copy 'Copy from cell(1,1) where cells(row number, column number). This will copy row 1, column 1, which is cell A1
            ws.Cells(c_row_number, "E").PasteSpecial xlPasteAll 'Paste into current row in loop and column 5 (column E)
        End If 'End the if statement where we check which value variable c has.
Next c 'Go to next c in the range

Application.CutCopyMode = False 'Cancel any copy selection
Application.ScreenUpdating = True 'Turn off screen update

End Sub