Insert/Delete 列基于单元格值

Question

我没有使用 Visual Basic 的经验，我正在尝试根据单元格值添加或删除列，同时保持与第一列相同的格式。我看过一些 post，但我的编程知识非常基础，我找不到调整变量以使其适合我的文件的方法。

以下代码似乎适用于我阅读的 post，但正如我所说，我不知道要更改什么才能使其在我的文件中工作：

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total")     'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2          'Column A & B for Company and ID

Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
        For i = TotalCol To LeftFixedCol + ColNum
        Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
        Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
        For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
            Columns(i).Delete
        Next i
End If
End Sub

问是否有人可以帮助识别每个代码行或给我一个更简单的代码来使用是不是太过分了？以下 gif 显示了我正在尝试做的事情：

谢谢！

Answer 1

一部作品sheet 更改：插入或删除列

此代码不得复制到标准模块中，例如Module1 和你一样。
需要复制到sheet模块，例如Sheet1、Sheet2、Sheet3（不在括号中的名称），您希望将此应用到的作品sheet。只需double-click在Project Explorerwindow中适当的工作sheet（见你截图的top-left），将代码复制到window 打开和退出 Visual Basic Editor.
代码运行会在您更改目标单元格中的值时自动执行（B1 使用此设置），即您不需要运行任何内容。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo ClearError
    ' e.g. to prevent
    ' "Run-time error '1004': Microsoft Excel can't insert new cells because
    '  it would push non-empty cells off the end of the worksheet.
    '  These non-empty cells might appear empty but have blank values,
    '  some formatting, or a formula. Delete enough rows or columns
    '  to make room for what you want to insert and then try again.",
    ' which is covered for the header row, as long there is nothing
    ' to the right of the total column, but not for other rows.
   
    Const TargetCellAddress As String = "B1"
    Const TotalFirstCellAddress As String = "D3"
    Const TotalColumnTitle As String = "Total" ' case-insensitive
    
    Dim TargetCell As Range
    Set TargetCell = Intersect(Me.Range(TargetCellAddress), Target)
    If TargetCell Is Nothing Then Exit Sub ' cell not contained in 'Target'
    
    Dim NewTotalIndex As Variant: NewTotalIndex = TargetCell.Value
    
    Dim isValid As Boolean ' referring to an integer greater than 0
    
    If VarType(NewTotalIndex) = vbDouble Then ' is a number
        If Int(NewTotalIndex) = NewTotalIndex Then ' is an integer
            If NewTotalIndex > 0 Then ' is greater than 0
                isValid = True
            End If
        End If
    End If
    
    If Not isValid Then Exit Sub
    
    Dim hrrg As Range ' Header Row Range
    Dim ColumnsDifference As Long
    
    With Range(TotalFirstCellAddress)
        Set hrrg = .Resize(, Me.Columns.Count - .Column + 1)
        If NewTotalIndex > hrrg.Columns.Count Then Exit Sub ' too few columns
        ColumnsDifference = .Column - 1
    End With
    
    Dim OldTotalIndex As Variant
    OldTotalIndex = Application.Match(TotalColumnTitle, hrrg, 0)
    If IsError(OldTotalIndex) Then Exit Sub  ' total column title not found
    
    Application.EnableEvents = False
    
    Dim hAddress As String
    
    Select Case OldTotalIndex
    Case Is > NewTotalIndex ' delete columns
        hrrg.Resize(, OldTotalIndex - NewTotalIndex).Offset(, NewTotalIndex _
            - ColumnsDifference + 2).EntireColumn.Delete xlShiftToRight
    Case Is < NewTotalIndex ' insert columns
        With hrrg.Resize(, NewTotalIndex - OldTotalIndex) _
                .Offset(, OldTotalIndex - 1)
            ' The above range becomes useless after inserting too many columns:
            hAddress = .Address
            .EntireColumn.Insert Shift:=xlToRight, _
                CopyOrigin:=xlFormatFromLeftOrAbove
        End With
        With Me.Range(hAddress)
            .Formula = "=""Column""&COLUMN()-" & ColumnsDifference - 1
            .Value = .Value
        End With
    Case Else ' is equal; do nothing
    End Select
    
SafeExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

Insert/Delete 列基于单元格值

Insert/Delete columns based on a cell value

excel

vba

一部作品sheet 更改：插入或删除列