A工作表变更：复制相同的公式

• 将代码复制到工作表的工作表模块（例如Sheet1）中要应用的位置（NOT在标准模块中，例如Module1）。
• 代码会自动运行，即无需运行任何内容。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' Start error-handling routine.
    On Error GoTo ClearError
    
    ' Define constants.
    Const TARGET_CELL As String = "A1"
    Const FIRST_SOURCE_CELL As String = "B2" ' adjust!
    
    ' Check if the value in the target cell has changed.
    Dim tCell As Range: Set tCell = Intersect(Me.Range(TARGET_CELL), Target)
    If tCell Is Nothing Then Exit Sub ' target value has not changed
    
    ' Check if the target value is valid.
    
    Dim CellValue As Variant: CellValue = tCell.Value
    
    Dim sfCell As Range: Set sfCell = Me.Range(FIRST_SOURCE_CELL)
    Dim sCol As Long: sCol = sfCell.Column
    
    Dim IsValid As Boolean

    If VarType(CellValue) = vbDouble Then ' is a number
        If CellValue = Int(CellValue) Then ' is an integer (whole number)
            If CellValue >= sCol Then
                If CellValue <= Me.Columns.Count - sCol + 1 Then IsValid = True
            End If
        End If
    End If

    If Not IsValid Then Exit Sub
    
    ' Reference the Source (single-column) range.
    
    If Me.FilterMode Then Me.ShowAllData
    
    Dim srg As Range, rCount As Long
    
    With sfCell
        Dim slCell As Range
        Set slCell = .Resize(Me.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        rCount = slCell.Row - .Row + 1
        Set srg = .Resize(rCount)
    End With
    
    ' Write the formulas from the Source range to an array.
    
    Dim Data() As Variant

    If rCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Formula
    Else
        Data = srg.Formula
    End If
    
    ' Resize the array to the necessary number of columns
    ' and copy the formulas from the first to the remaining columns.
    
    Dim cCount As Long: cCount = CLng(CellValue) - 1
    
    If cCount > 1 Then
        
        ReDim Preserve Data(1 To rCount, 1 To cCount)
            
        Dim r As Long, c As Long
        
        For r = 1 To rCount
            For c = 2 To cCount
                Data(r, c) = Data(r, 1)
            Next c
        Next r
    
    End If
    
    ' Write the formulas from the array to the Destination range.
    
    Application.EnableEvents = False
        sfCell.Offset(, 1).Resize(rCount, cCount).Formula = Data
    
ProcExit:
    On Error Resume Next
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
' Continue error-handling routine.
ClearError:
    Debug.Print "Run-time error '" & Err.Number & ":" _
        & vbLf & vbLf & Err.Description
    Resume ProcExit
End Sub