當復選框打開時，將文本寫入另一個單元格

我有兩張sheet1 = "output"和sheet2="input"。在sheet2中有多個復選框分配給某些特定變數。例如：

現在我想要的是如果任何復選框是 On 然后將其變數名寫入Sheet1，否則將單元格留空

假設如果checkbox1、checkbox3和checkbox4為 On 然后在sheet1的單元格 B2、B4、B5 中寫入“flow”、“size”和“current” ，并在單元格 B1 中寫入“XYZ”。sheet1 = 輸出應如下所示：

到目前為止，我定義了什么：

Sub chart()

Dim s1 As Worksheet, s2 As Worksheet
Dim check1 As Boolean, check2 As Boolean, check3 As Boolean, check4 As Boolean

Set s1 = ThisWorkbook.Worksheets(1)
Set s2 = ThisWorkbook.Worksheets(2)

check1 = s2.CHECKBOXES("Check Box 1").Value = xlOn
check2 = s2.CHECKBOXES("Check Box 2").Value = xlOn
check3 = s2.CHECKBOXES("Check Box 3").Value = xlOn
check4 = s2.CHECKBOXES("Check Box 4").Value = xlOn

End Sub`

現在我想寫 if 條件。

uj5u.com熱心網友回復：

你可以這樣做（假設復選框在 ws2 中）：

sub code()
Dim ws as worksheet: set ws = Thisworkbook.Worksheets("input")
Dim ws2 as worksheet: set ws2 = Thisworkbook.Worksheets("output")

   With ws2
      If .OLEObjects("checkbox1").Object.Value = True And _
         .OLEObjects("checkbox2").Object.Value = True And _
         .OLEObjects("checkbox3").Object.Value = True Then

          ws.Range("B1").Value = "current"
          ws.Range("B2").Value = "flow"
          ws.Range("B2").Value = "size"
          ws.Range("B2").Value = "current"
      end if
   end with      
end sub

uj5u.com熱心網友回復：

請測驗下一個代碼。它適用于Form復選框型別，并且需要文本框名稱與要回傳的 B:B 中的單詞之間的對應關系。我說的是他們的名字（在左邊的地址文本框中），而不是他們的標題（通過編輯自動分配的標題）。這樣，您可以使用任意數量的復選框。只是為了讓他們的名字與要回傳的字串所在的行相關：

Sub WriteOnChckBoxFVal()
   Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrFin, i As Long
   
   Set sh1 = ActiveSheet 'ThisWorkbook.Worksheets(1)
   Set sh2 = sh1.Next     'ThisWorkbook.Worksheets(2)
   lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).Row
   arr = sh1.Range("B2:B" & lastR).Value2
   ReDim arrFin(1 To UBound(arr), 1 To 1)
   
   For i = 1 To UBound(arr)
        If sh1.CheckBoxes("Check Box " & i).value = 1 Then
            arrFin(i, 1) = arr(i, 1)
        Else
            arrFin(i, 1) = "XYZ"
        End If
   Next i
   'drop the array content at once:
   sh2.Range("B2").Resize(UBound(arrFin), 1).value = arrFin
End Sub

編輯：

下一個版本也適用于任何數量的復選框，它們的編號以任何方式，但它們的左上角放置在列 C:C 和要回傳的字串的行上。如果存在間隙，則回傳的陣列將從具有間隙的行開始貼花......：

Private Sub BringSensorsByChkBoxesVal()
   Dim sh1 As Worksheet, sh2 As Worksheet, lastR As Long, arr, arrFin, i As Long, dict As New Scripting.Dictionary
   Const colLet As String = "G"
   
   Set sh1 = ThisWorkbook.Worksheets(1)
   Set sh2 = ThisWorkbook.Worksheets(2)
   lastR = sh1.Range("B" & sh1.rows.count).End(xlUp).Row
   arr = sh1.Range("B2:B" & lastR).Value2
   ReDim arrFin(1 To UBound(arr), 1 To 1)
   Set dict = CreateObject("Scripting.Dictionary")
   
   For i = 1 To sh1.CheckBoxes.count
        'process only Form check boxes located in C:C column:
        If Not Intersect(sh1.CheckBoxes(i).TopLeftCell, sh1.Range("C:C")) Is Nothing Then
            dict(sh1.CheckBoxes(i).TopLeftCell.Row) = _
                      IIf(sh1.CheckBoxes(i).value = 1, sh1.Range("B" & sh1.CheckBoxes(i).TopLeftCell.Row).value, "XYZ")
        End If
   Next i
   Set dict = sortDictionaryByKeys(dict) 'sort dictionary  by keys

   'drop the dictionary items at once:
   sh2.Range("B2").Resize(dict.count, 1).value = Application.Transpose(dict.Items)
   MsgBox "Ready..."
End Sub

Private Function sortDictionaryByKeys(dict As Object, Optional boolAsccend As Boolean = True) As Object 'sorting a dictionary
    Dim arrDict, tmpKey, i As Long, j As Long

    'Only sort if more than one item in the dict
    If dict.count < 1 Then Set sortDictionaryByKeys = dict: Exit Function
    
    'place the dict keys in an array:
    arrDict = dict.Keys

    'Do the bubble sort of the array:
    For i = 0 To (dict.count - 2)
        For j = i   1 To dict.count - 1
            If IIf(boolAsccend, arrDict(i) > arrDict(j), arrDict(i) < arrDict(j)) Then
                tmpKey = arrDict(j): arrDict(j) = arrDict(i)
                arrDict(i) = tmpKey
            End If
        Next
    Next

    'Create the new dictionary and load it using arrDict keys and dict items:
    Set sortDictionaryByKeys = CreateObject("Scripting.Dictionary")
    For i = 0 To (dict.count - 1)
        sortDictionaryByKeys.Add arrDict(i), dict(arrDict(i))
    Next
End Function

uj5u.com熱心網友回復：

Sub main_process_data()
 Dim s1 As Worksheet, s2 As Worksheet
 Dim check1 As Boolean, check5 As Boolean, check6 As Boolean, check7 As Boolean, check13 As Boolean

Set s1 = ThisWorkbook.Worksheets(1)
Set s2 = ThisWorkbook.Worksheets(2)

check1 = s2.CHECKBOXES("Check Box 1").Value = xlOn
check5 = s2.CHECKBOXES("Check Box 5").Value = xlOn
check6 = s2.CHECKBOXES("Check Box 6").Value = xlOn
check7 = s2.CHECKBOXES("Check Box 7").Value = xlOn
check13 = s2.CHECKBOXES("Check Box 13").Value = xlOn

If check1 Then
    s1.Range("C42").Value = s2.Range("B2").Value
Else
    s1.Range("C42").Value = vbNullString
End If

If check5 Then
    s1.Range("C43").Value = s2.Range("B3").Value
Else
    s1.Range("C43").Value = vbNullString
End If

If check6 Then
    s1.Range("C44").Value = s2.Range("B4").Value
Else
    s1.Range("C44").Value = vbNullString
End If

If check7 Then
    s1.Range("C45").Value = s2.Range("B5").Value
Else
    s1.Range("C45").Value = vbNullString
End If

If check13 Then
    s1.Range("C46").Value = s2.Range("B11").Value
Else
    s1.Range("C46").Value = vbNullString
End If




End Sub

標籤：擅长 vba 复选框

上一篇：通過替換VBA中的文本來編輯Outlook本地保存的.msg正文

下一篇：如何找到具有兩個關鍵字的檔案并回傳在特定列/行中修改的日期？