VBA：寻求代码修改方面的帮助

Question

我是VBA学习者，我正在尝试建立一个VBA项目来提高我的知识水平。关于如何将不同数据（基于某些条件）填充到一组相同字段中存在轻微的混淆。

我有3个场景：

场景1：用户选择所有复选框 场景2：用户仅选择1或2复选框 场景3：用户没有选择任何内容

我的代码将与方案1和3完美配合，但无法弄清楚如何完成方案2。

我的期望是根据用户在弹出Userform时选择的内容，将单元格B3中的值填充到B17。如果他只选择1个字段，则应从B3-B8填充相应的值，如果他选择2个复选框，则第一个对应的值将从B3-B8填充，第二个从B9-B14填充，依此类推。请查看下面的图片以便更好地理解

用户窗体

场景1的示例

场景3的示例

VBA代码

Dim i As Integer
i = 3
Do While i < 8 And UF1_Location_and_Role.CheckBox6.Value = True
    Cells(i, 2).Value = "India"
    i = i + 1
Loop

Do While i < 13 And UF1_Location_and_Role.CheckBox7.Value = True
    Cells(i, 2).Value = "Germany"
    i = i + 1
Loop

Do While i < 18 And UF1_Location_and_Role.CheckBox7.Value = True
    Cells(i, 2).Value = "Hongkong"
    i = i + 1
Loop

Answer 1

我想你想要更像下面代码的东西。此代码可以进一步改进为一个函数，您可以在其中传递国家/地区的名称和当前行，从而消除重复的代码

 Sub PopulateSheet()
 Dim lngCurrentRow As Long

'start row
lngCurrentRow = 3

If chkIndia Then

    Sheet.Range("B" & lngCurrentRow & ":B" & lngCurrentRow + 4) = "India"

    lngCurrentRow = lngCurrentRow + 5

End If

 If chkGermany Then

    Sheet.Range("B" & lngCurrentRow & ":B" & lngCurrentRow + 4) = "Germany"

    lngCurrentRow = lngCurrentRow + 5

End If


If chkHK Then

    Sheet.Range("B" & lngCurrentRow & ":B" & lngCurrentRow + 4) = "Hong Kong"

    lngCurrentRow = lngCurrentRow + 5

End If

End Sub

更新功能：

Sub PopulateSheet()
Dim lngCurrentRow As Long

'start row
lngCurrentRow = 3

If chkIndia Then Call WriteOutput("India", lngCurrentRow)
If chkGermany Then Call WriteOutput("Germany", lngCurrentRow)
If chkHK Then Call WriteOutput("Hong Kong", lngCurrentRow)

End Sub

Function WriteOutput(strCountry As String, ByRef lngRowToWriteTo As Long)

ActiveSheet.Range("B" & lngRowToWriteTo & ":B" & lngRowToWriteTo + 4) = strCountry

lngRowToWriteTo = lngRowToWriteTo + 5

End Function

然后，您可以将4设置为常量（您希望国家/地区显示在工作表中的次数），将5设置为常量+ 1

更新为CONSTANTS，这提供了最大的灵活性：

    Private Const START_ROW As Long = 3
    Private Const NUM_COUNTRY_ROWS As Long = 4
    Private Const COLUMN_TO_WRITE_TO As String = "B"

    Sub PopulateSheet()
    Dim lngCurrentRow As Long

        'start row
        lngCurrentRow = START_ROW

        If True Then Call WriteOutput("India", lngCurrentRow)
        If True Then Call WriteOutput("Germany", lngCurrentRow)
        If True Then Call WriteOutput("Hong Kong", lngCurrentRow)

    End Sub

    Function WriteOutput(strCountry As String, ByRef lngRowToWriteTo As Long)

        ActiveSheet.Range(COLUMN_TO_WRITE_TO & lngRowToWriteTo & ":" & COLUMN_TO_WRITE_TO & lngRowToWriteTo + NUM_COUNTRY_ROWS) = strCountry

        lngRowToWriteTo = lngRowToWriteTo + NUM_COUNTRY_ROWS + 1

    End Function

更新包括合并（注意您现在只需要写一次国家）

Private Const START_ROW As Long = 3
Private Const NUM_COUNTRY_ROWS As Long = 4
Private Const COLUMN_TO_WRITE_TO As String = "B"

Sub PopulateSheet()
Dim lngCurrentRow As Long

    'start row
    lngCurrentRow = START_ROW

    If chkIndia Then Call WriteOutput("India", lngCurrentRow)
    If chkGermany Then Call WriteOutput("Germany", lngCurrentRow)
    If chkHK Then Call WriteOutput("Hong Kong", lngCurrentRow)

End Sub

Function WriteOutput(strCountry As String, ByRef lngRowToWriteTo As Long)

    With ActiveSheet

        .Range(COLUMN_TO_WRITE_TO & lngRowToWriteTo) = strCountry

        .Range(.Range(COLUMN_TO_WRITE_TO & lngRowToWriteTo), .Range(COLUMN_TO_WRITE_TO & lngRowToWriteTo + NUM_COUNTRY_ROWS)).Cells.Merge

    End With

    lngRowToWriteTo = lngRowToWriteTo + NUM_COUNTRY_ROWS + 1

End Function

Answer 2

而不是使用Do使用If声明

Dim i As Integer
i = 3
If UF1_Location_and_Role.CheckBox6.Value = True Then
  Do While i < 8
    Cells(i, 2).Value = "India"
    i = i + 1
  Loop
End If

If UF1_Location_and_Role.CheckBox7.Value = True Then
  Do While i < 13
    Cells(i, 2).Value = "Germany"
    i = i + 1
  Loop
End If 

If UF1_Location_and_Role.CheckBox7.Value = True Then
  Do While i < 18
    Cells(i, 2).Value = "Hongkong"
    i = i + 1
  Loop
End If

Answer 3

这是另一种方法。

Sub test()
    Dim rngT As Range
    Dim rngDB() As Range, n As Integer, i As Integer

    If UF1_Location_and_Role.CheckBox6.Value Then
        Set rngT = Range("b" & Rows.Count).End(xlUp)(2)
        rngT.Resize(5) = "India"
        n = n + 1
        ReDim Preserve rngDB(1 To n)
        Set rngDB(n) = rngT.Resize(5)
    End If
    If UF1_Location_and_Role.CheckBox7.Value Then
        Set rngT = Range("b" & Rows.Count).End(xlUp)(2)
        rngT.Resize(5) = "Germany"
        n = n + 1
        ReDim Preserve rngDB(1 To n)
        Set rngDB(n) = rngT.Resize(5)
    End If
    If UF1_Location_and_Role.CheckBox8.Value Then
        Set rngT = Range("b" & Rows.Count).End(xlUp)(2)
        rngT.Resize(5) = "Hongkong"
        n = n + 1
        ReDim Preserve rngDB(1 To n)
        Set rngDB(n) = rngT.Resize(5)
    End If
    Application.DisplayAlerts = False
    For i = 1 To n
        rngDB(i).Merge
    Next i
    Application.DisplayAlerts = True
End Sub