使用循环中的单个单元格作为触发器来复制多个范围 VBA

Question

宏正在处理硬编码输入，但我需要循环来进行调试和未来的增长。我不知道最好的设置方法。

Range("b3:b8:) 是我想要循环的单元格。

如果 cell.value = 1 那么
Set var1 = range("a3:aq3") (* 这个范围总是和循环中的单元格具有相同的行号*)

Set var2 = range("a9:aq9") (*这个范围总是比循环中的单元格行大6。)

如果结束

下一个单元格 谢谢

Answer 1

循环遍历范围的行

Option Explicit

Sub LoopThroughRows()
    
    Const srgAddress As String = "A3:AQ8"
    Const scCol As Long = 2
    Const sCriteria As String = "1"
    
    Dim sws As Worksheet: Set sws = ActiveSheet ' improve, e.g.:
    'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    'Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    Dim srg As Range: Set srg = sws.Range(srgAddress) ' last use of 'sws'
    Dim srCount As Long: srCount = srg.Rows.Count
    
    Dim srg1 As Range
    Dim srg2 As Range
    Dim sCell As Range
    Dim sr As Long
    
    For Each sCell In srg.Columns(scCol).Cells ' don't forget '.Cells'!
        sr = sr + 1 ' monitoring each range row (not worksheet row)
        If CStr(sCell.Value) = sCriteria Then ' also avoiding error values
            Set srg1 = srg.Rows(sr)
            Set srg2 = srg1.Offset(srCount)
            ' Continue... e.g.:
            Debug.Print sr, sCell.Address(0, 0), _
                srg1.Address(0, 0), srg2.Address(0, 0)
        Else ' not equal to sCriteria (usually do nothing)
            ' e.g.:
            Debug.Print sr, sCell.Address(0, 0), "Nope."
        End If
    Next sCell
    
End Sub

Answer 2

您是否尝试过使用 for 循环？

例如：

For Each Cell in Range("B3:B8")
  If Cell.Value = 1 Then
    Set var1 = range("a3:aq3")
  Else
    Set var2 = range("a9:aq9")
  End If
Next Cell