Question

Text

我试图弄清楚如何编写一个宏，该宏将根据B1中的单元格值在“ ID”和“ Total”之间添加列（如果数目减少，则将其删除）。如果有人对我如何编写可以在每次更新单元格时自动完成的事情有想法，我将不胜感激。

编辑：我到目前为止的代码

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        Dim i As Integer
        For i = 1 To Range("B1").Value
            Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Next i
End If
End Sub

Answer 1

可以尝试下面的代码以得到如下结果

代码或多或少是自我解释的

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

但是，要保持求和公式的总和与添加的列一致，可以通过更改以下内容将最小列数限制为2，并在现有列之间插入列

If ColNum <= 1 Then Exit Sub

和

Columns(i - 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

还删除行插入列标题

Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line

否则，可以添加VBA代码以将总列的formula更改为要求。

Answer 2

您可以尝试以下方法。命名范围已定义：

“ B1”->“ ColumnNumber”
“ B3”->“ Header.ID”
“ F3”->“ Header.Total”（但是随着您添加/删除列而改变）”

Private Sub Worksheet_Change（按目标的ByVal目标）

Dim headerId As Range, headerTotal As Range, columnNumber As Range
Dim currentNumberOfColumns As Integer, targetNumberOfColumns As Integer
Dim columnsToAdd As Integer, columnsToRemove As Integer
Dim i As Integer

On Error GoTo error_catch

Application.EnableEvents = False

Set columnNumber = Me.Range("ColumnNumber")

If Not Application.Intersect(columnNumber, Target) Is Nothing Then

    Set headerId = Me.Range("Header.ID")
    Set headerTotal = Me.Range("Header.Total")

    targetNumberOfColumns = columnNumber.Value
    If targetNumberOfColumns <= 0 Then
        Application.EnableEvents = True
        Exit Sub
    End If

    currentNumberOfColumns = headerTotal.Column - headerId.Column - 1
    Debug.Print "Currently there are " & currentNumberOfColumns & " columns"

    If currentNumberOfColumns = targetNumberOfColumns Then
        Application.EnableEvents = True
        Exit Sub
    Else
        If targetNumberOfColumns > currentNumberOfColumns Then
            columnsToAdd = targetNumberOfColumns - currentNumberOfColumns
            Debug.Print "Need to add " & columnsToAdd & " columns"

            For i = 1 To columnsToAdd
                headerTotal.Offset(0, -1).EntireColumn.Select
                Selection.Copy
                headerTotal.EntireColumn.Select
                Selection.Insert Shift:=xlToRight
            Next i

        Else
            columnsToRemove = -(targetNumberOfColumns - currentNumberOfColumns)
            Debug.Print "Need to remove " & columnsToRemove & " columns"

            For i = 1 To columnsToRemove
                headerTotal.Offset(0, -1).EntireColumn.Select
                Selection.Delete Shift:=xlToLeft
            Next i

        End If
    End If

End If

columnNumber.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub

error_catch:
MsgBox Err.Description
Application.EnableEvents = True

结束子

Answer 3

您的代码中存在许多问题：

不合格的范围引用引用默认的图纸对象。在这种情况下不会有问题（在模块后面的工作表代码中，对象是包含代码的工作表，而在其他模块的Activesheet中则是），这是一个坏习惯。使用关键字Me来引用代码所在的工作表。
在Worksheet_Change事件中更改工作表时，请使用Application.EnableEvents = False防止事件级联（每次代码更改工作表时，都会再次调用该事件）
使用错误处理程序将其重新打开（Application.EnableEvents = True）
根据现有列计算要插入或删除多少列
检查用户输入的范围以确保其有效
在一个区块中插入或删除
假设“总计”列包含用于汇总行的公式（例如，对于2列，第4行，它可能是=Sum($C4:$D4)，当您在列C插入列时，公式将不会包括新列。如果需要，代码可以更新公式。
Target已经是一个范围。无需获取其地址作为字符串，然后将其转回一个范围，即可直接使用

您的代码，经过重构：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim NumColumnsRequired As Long
    Dim NumExistingColumns As Long
    Dim NumToInsertOrDelete As Long
    Dim TotalsRange As Range

    On Error GoTo EH

    Set KeyCells = Me.Range("B1")
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        ' Validate Entry
        If Not IsNumeric(KeyCells.Value) Then Exit Sub
        NumColumnsRequired = KeyCells.Value
        If NumColumnsRequired <= 0 Or NumColumnsRequired > 16380 Then Exit Sub

        Application.EnableEvents = False
        NumExistingColumns = Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column - 3
        NumToInsertOrDelete = NumColumnsRequired - NumExistingColumns
        Select Case NumToInsertOrDelete
            Case Is < 0
                ' Delete columns
                Me.Columns(3).Resize(, -NumToInsertOrDelete).Delete
            Case Is > 0
                ' Insert columns
                Me.Columns(3).Resize(, NumToInsertOrDelete).Insert CopyOrigin:=xlFormatFromLeftOrAbove

                'Optional: update Total Formulas
                Set TotalsRange = Me.Cells(Me.Rows.Count, Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column).End(xlUp)
                If TotalsRange.Row > 3 Then
                    Set TotalsRange = Me.Range(TotalsRange, Me.Cells(4, TotalsRange.Column))
                    TotalsRange.Formula2R1C1 = "=Sum(RC3:RC" & TotalsRange.Column - 1 & ")"
                End If
            Case 0
                ' No Change
        End Select
    End If
EH:
    Application.EnableEvents = True
End Sub

VBA-根据单元格值添加或删除列

3 个答案: