根據單元格值插入/洗掉列

我沒有使用 Visual Basic 的經驗，我正在嘗試根據單元格值添加或洗掉列，同時保持與第一列相同的格式。我看過一些帖子，但我的編程知識非常基礎，我找不到調整變數以使其適合我的檔案的方法。

以下代碼似乎適用于我閱讀的帖子，但正如我所說，我不知道要更改什么才能使其在我的檔案中作業：

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 正是我想要做的事情：

預先感謝！

uj5u.com熱心網友回復：

作業表更改：插入或洗掉列

• 不能Module1像您那樣將這段代碼復制到標準模塊中。
• 需要將其復制到您希望應用此功能的作業表的作業表模塊中，例如Sheet1, Sheet2（括號中沒有的名稱）。Sheet3只需雙擊Project Explorer視窗中的相應作業表（在螢屏截圖的左上方），將代碼復制到打開的視窗并退出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

標籤：擅长 vba

上一篇：在VBA中動態格式化特定單元格

下一篇：通過替換VBA中的文本來編輯Outlook本地保存的.msg正文