在命名范围中添加或删除列并复制公式

Question

我有一个工作表，我试图在命名范围“DA_Data”中添加或删除列。该范围始终从第 1 行开始，如果插入列，则仅将公式和格式从该列复制到左侧。我需要一个输入框来询问我是否要“添加或删除”列。 如果添加，需要询问我“插入多少”和“在哪列字母插入” 如果删除，需要询问我“要删除哪一列字母”

下面这段优秀的代码（再次感谢@taller）在添加行时就像一个魅力，所以我希望使用它作为列的基础，但我在尝试修改它时有点迷失，因为它插入了整个行等....

Option Explicit

Sub InsertRows2()
    Dim Rng As Range, xTitleId As String
    Dim WorkRng As Range, xLastRow As Long, xRowIndex As Long
    Dim iRow, iCount, i As Long
    'set column reference
    Const COL_INDEX = 2
    xTitleId = "  "
    iCount = Application.InputBox(Title:=xTitleId, Prompt:="     How many rows do you want to add?")
    If (Not IsNumeric(iCount)) Or Val(iCount) < 1 Then
        MsgBox "The input is not a valid number"
        Exit Sub
    End If
    iRow = Application.InputBox(Title:=xTitleId, Prompt:="After which row do you want to add new rows? (Enter the row number)")
    If (Not IsNumeric(iRow)) Or Val(iRow) < 1 Then
        MsgBox "The input is not a valid number"
        Exit Sub
    End If
    Set WorkRng = ActiveSheet.UsedRange
    Dim formulaRng As Range
    If WorkRng.Columns.Count > 1 Then _
        Set formulaRng = WorkRng.Resize(1, WorkRng.Columns.Count - 1).Offset(, 1).EntireColumn
    Set WorkRng = WorkRng.Columns(COL_INDEX)
    xLastRow = WorkRng.Rows.Count
    Application.ScreenUpdating = False
    For xRowIndex = xLastRow To 1 Step -1
    'Set Column to "B"
        Set Rng = WorkRng.Range("A" & xRowIndex)
        If Rng.Row > iRow Then
        'Find "Start" and add rows
            If Rng.Value = "Start" Then
                Rng.Offset(1, 0).Resize(iCount).EntireRow.Insert
                If Not formulaRng Is Nothing Then
                    Intersect(Rng.Resize(iCount + 1).EntireRow, formulaRng).FillDown
                    Rng.Offset(1, 0).Resize(iCount).ClearContents
                End If
            End If
        End If
     Next
    Application.ScreenUpdating = True
    Call ExclamationMesageBox
End Sub

下面可以添加整个列，而不仅仅是在我的范围内，但不会复制公式，所以我又有点迷失了

Sub InsertColumns_Ask()


Dim iCol As Long
Dim iCount As Long
Dim i As Long


iCount = InputBox(Prompt:="How many column you want to add?")


iCol = InputBox _
(Prompt:= _
"After which column you want to add new column? (Enter the column number)")


For i = 1 To iCount
    Columns(iCol).EntireColumn.Insert
Next i

End Sub

非常感谢任何帮助。

Answer 1

• 编码逻辑类似。

注意：测试前请先备份文件。

Option Explicit

Sub AddRemoveCols()
    Dim colRng As Range, xTitleId As String
    Dim TabRng As Range
    Dim sCol As String, iCount, sMode As String
    Const MODE_ADD = "ADD"
    Const MODE_REMOVE = "REMOVE"
    xTitleId = "  "
    Dim oSht As Worksheet
    Set oSht = Sheets("Sheet1")  ' modify as needed
    Set TabRng = oSht.Range("DA_Data")
    Application.ScreenUpdating = False
    sMode = Application.InputBox(Title:=xTitleId, Prompt:="     Do you want to add and remove cols?")
    Select Case UCase(sMode)
    Case MODE_ADD
        iCount = Application.InputBox(Title:=xTitleId, Prompt:="     How many rows do you want to add?")
        If (Not IsNumeric(iCount)) Or Val(iCount) < 1 Then
            MsgBox "The input is not a valid number"
            Exit Sub
        End If
        sCol = Application.InputBox(Title:=xTitleId, Prompt:="At what column letter to insert? (Enter the col name)")
        On Error Resume Next
        Set colRng = oSht.Columns(sCol)
        On Error GoTo 0
        If colRng Is Nothing Then
            MsgBox "The input is not a valid col name"
            Exit Sub
        End If
        If Application.Intersect(colRng, TabRng) Is Nothing Then
            MsgBox "The Col is not in the table [DA_Data]"
            Exit Sub
        End If
        colRng.Resize(, iCount).Insert
        If UCase(sCol) = "A" Then
            MsgBox "Can't copy format and formulas from left col."
        Else
            With oSht.Columns(sCol)
                .Offset(, -1).Copy .Resize(, iCount)
            End With
        End If
    Case MODE_REMOVE
        iCount = Application.InputBox(Title:=xTitleId, Prompt:="     How many COLs do you want to remove?")
        If (Not IsNumeric(iCount)) Or Val(iCount) < 1 Then
            MsgBox "The input is not a valid number"
            Exit Sub
        End If
        sCol = Application.InputBox(Title:=xTitleId, Prompt:="Which column letter to remove? (Enter the first col name)")
        On Error Resume Next
        Set colRng = oSht.Columns(sCol)
        On Error GoTo 0
        If colRng Is Nothing Then
            MsgBox "The input is not a valid col name"
            Exit Sub
        End If
        If Application.Intersect(colRng, TabRng) Is Nothing Then
            MsgBox "The Col is not in the table [DA_Data]"
            Exit Sub
        End If
        Application.Intersect(colRng.Resize(, iCount), TabRng).EntireColumn.Delete
    Case Else
        MsgBox "The input is invalid."
        Exit Sub
    End Select
    Application.ScreenUpdating = True
End Sub