VBA Excel 循環與增量行和列

Question

因此，我對使用 excel 的 VBA 代碼非常陌生，並且我正在嘗試創建一個“修改日期”列，以便為工作中的清單編輯前一列中的值。 我以前為另一個清單做過一次，但我用老式的方式做，因為它不是一個很長的清單。 但是對於這個應用程序，這根本沒有效率，因為這個列表將持續進行。 我使用社區中其他人的其他示例拼湊了這段代碼，但我無法弄清楚錯誤的來源。 這是說有一個編譯錯誤'Do without Loop'。 根據我對其他帖子的理解，它認為'If'語句沒有被關閉，但我使用了'End If'並且我的代碼中只有一個'If'語句。 我需要它從第 6 列開始交替列，然后重復每一行。 任何幫助深表感謝！

Sub Worksheet_Change(ByVal Target As Range)
Dim ColCount As Long
    ColCount = 6
Dim RowCount As Long
    RowCount = 2
Dim iCol As Long
    iCol = 7
Dim iRow As Long
    iRow = 2
Do While RowCount < 2
    Do While ColCount < 6
        Do While iCol < 7
            Do While iRow < 2
            
                If Target.Column = ColCount And Target.Row = RowCount Then
                    ActiveSheet.Cells(iRow, iCol).Value = Format(Date, "mm/dd/yyyy")
                End If
                
                RowCount = RowCount + 1
                ColCount = ColCount + 2
                iCol = iCol + 2
                iRow = iRow + 1

Loop

End Sub

Answer 1

更簡單的方法：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, c As Range
    
    Set rng = Application.Intersect(Target, Me.Range("F:F,H:H,J:J")) 'adjust to suit...
    If rng Is Nothing Then Exit Sub 'no updates in monitored range
    
    For Each c In rng.Cells
        c.Offset(0, 1).Value = Format(Date, "mm/dd/yyyy")
    Next c

End Sub

Answer 2

在每個其他列旁邊添加一個日期戳

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    AddDateStamp Target
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Adds a datestamp next to every other column.
' Calls:        'RefWsColumnsFirstRow','RefRangeNthColumns'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AddDateStamp(ByVal Target As Range)
    Const ProcName As String = "AddDateStamp"
    On Error GoTo ClearError
    
    Const Cols As String = "F:BA"
    Const fRow As Long = 2 ' '2' excludes headers in first row
    Const cStep As Long = 2
    Const dcOffset As Long = 1
    Const ddFormat As String = "mm/dd/yy" ' "mm/dd/yy hh:mm:ss" '
    Const DoExcludeFirstColumn As Boolean = False ' 'False: F, H, J... AZ'
    
    Dim crg As Range ' 'F2:BA1048576' ('F2:BA65536' for older versions)
    Set crg = RefWsColumnsFirstRow(Target.Worksheet, Cols, fRow)
    Dim srg As Range ' 'F2:F1048576, H2:H..., J2:J..., ... , AZ2:AZ1048576'
    Set srg = RefRangeNthColumns(crg, cStep, DoExcludeFirstColumn)

    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    If sirg Is Nothing Then Exit Sub
    
    Dim drg As Range: Set drg = sirg.Offset(, dcOffset)
    
    Application.EnableEvents = False
    drg.Value = Format(Date, ddFormat) ' 'Now' (instead of 'Date')

SafeExit:
    
    If Not Application.EnableEvents Then Application.EnableEvents = True
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume SafeExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a columns ('ColumnsAddress') range
'               from the first row ('FirstRow') to the bottom-most
'               worksheet's ('ws') row.
' Example:      'If ColumnsAddress = "B:E" and FirstRow = 5 Then "B5:E1048576"'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWsColumnsFirstRow( _
    ByVal ws As Worksheet, _
    Optional ByVal ColumnsAddress As String = "A:A", _
    Optional ByVal FirstRow As Long = 1) _
As Range
    Const ProcName As String = "RefWsColumnsFirstRow"
    On Error GoTo ClearError

    Set RefWsColumnsFirstRow = ws.Columns(ColumnsAddress) _
        .Resize(ws.Rows.Count - FirstRow + 1).Offset(FirstRow - 1)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference combined from every n-th ('NthStep') column
'               of a range ('rg').
'               The default value of 'DoExcludeFirstColumn' is 'False' i.e.
'               e.g. if 'NthStep' = 2 then the columns are 1, 3, 5...etc.;
'               otherwise, the columns are 2, 4, 6...etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefRangeNthColumns( _
    ByVal rg As Range, _
    Optional ByVal NthStep As Long = 1, _
    Optional ByVal DoExcludeFirstColumn As Boolean = False) _
As Range
    Const ProcName As String = "RefRangeNthColumns"
    On Error GoTo ClearError
    
    Dim Col1 As Long, ColGT As Long, Col2 As Long
    If DoExcludeFirstColumn Then
        Col1 = NthStep: ColGT = 2 * NthStep - 1: Col2 = 2 * NthStep
    Else
        Col1 = 1: ColGT = NthStep: Col2 = 1 + NthStep
    End If
        
    Dim crg As Range: Set crg = rg.Columns(Col1)
    Dim scCount As Long: scCount = rg.Columns.Count
    
    Dim c As Long
    If scCount > ColGT Then
        For c = Col2 To scCount Step NthStep
            Set crg = Union(crg, rg.Columns(c))
        Next c
    End If

    Set RefRangeNthColumns = crg

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function