Insert/Delete Columns issue via VBA

T

Tdorman

Board Regular
Joined
Aug 12, 2021
Messages
50
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I have a workbook that was previously working with no issues. Recently, however, I have been having a problem with adding/deleting columns on visible sheets after I run certain macros.

The workbook is used for groups of members. When data is imported into the file a base number of members are included. Throughout the use of the file the group can expand or contract. I have macros that will add new members or delete existing ones. These macros simply add data or remove it from specific data sheets. Another macro is used to refresh the keycells range that is used to adjust the columns on the visible sheets.

The issue I am having is that once I either add a new member or delete one, the code to increase or delete columns on the visible sheets does not work. The macro that refreshes the sheet doesn't work, nor does manually adjusting the cell itself.

If I do not import any data and simply add or delete columns from visible sheets, the code runs perfectly. It seems to only occur when I import data and try using macros that add or delete members. For example, without any data, I can add in 3 members and have new columns added in to each visible sheet. I can then reduce that number manually to 1 or 2 and have the appropriate number of columns deleted for each sheet. This works fine until data is imported and the other mentioned macros are used.

I also am experiencing an issue with the file where once I receive an error even if I reset it I cannot continue working in it. It locks up and freezes to the point where I have to end it and reopen it again.


This is the code that is used to refresh the keycell

VBA Code: 
Sub Refresh_ActivesheetB30()

    Dim dwsNames As Variant: dwsNames = Array("DATA Member-19", "DATA Sch A-19", "DATA Sch A-3-19", "DATA Sch J-19", "DATA Sch R-19", "DATA 500U-19", "DATA 500U-P-19", "DATA 500U-PA-19")

    frmWait.Show vbModeless
    DoEvents
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim wb As Workbook: Set wb = ThisWorkbook
  
    Dim gws As Worksheet: Set gws = wb.Worksheets("GroupInfo")
    gws.Range("B30").Formula = "=COUNTIF('TAX INFO'!B34:B1499,"">0"")"

    Dim dws As Worksheet
    Dim dlRow As Long
    Dim d As Long
  
    For d = LBound(dwsNames) To UBound(dwsNames)
        On Error Resume Next
        Set dws = wb.Worksheets(dwsNames(d))
        On Error GoTo 0
        If Not dws Is Nothing Then
            dlRow = dws.Range("D" & dws.Rows.Count).End(xlUp).Row
            dws.Range("A12").Copy dws.Range("A12:A" & dlRow)
            Set dws = Nothing
        End If
    Next d
  
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    gws.Activate
    frmWait.Hide

End Sub


This code adds members

VBA Code: 
Option Explicit
Private Sub CommandButton1_Click()

Dim ws As Worksheet
Dim N As Long
Dim i As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim Rng5 As Range


Set ws = ActiveSheet
Set Rng1 = ws.Range("6:6").Find(Me.TextBox2.Value)
Set Rng2 = ws.Range("6:6").Find(Me.TextBox6.Value)
Set Rng3 = ws.Range("6:6").Find(Me.TextBox5.Value)
Set Rng4 = ws.Range("6:6").Find(Me.TextBox4.Value)
Set Rng5 = ws.Range("6:6").Find(Me.TextBox7.Value)

N = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row

If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox2, ws.Range("6:6"), TextBox2) = 0 And ComboBox1 <> 0 Then
 MsgBox "Sorry, " & TextBox2 & " not found!"
    Else
If TextBox3.Value = "" And ComboBox1.Value <> "" Then
        MsgBox "There is no data to add", 48
    Else
  
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox6, ws.Range("6:6"), TextBox6) = 0 And ComboBox2 <> 0 Then
 MsgBox "Sorry, " & TextBox6 & " not found!"
    Else
If TextBox8.Value = "" And ComboBox2.Value <> "" Then
        MsgBox "There is no data to add", 48
    Else
  
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox5, ws.Range("6:6"), TextBox5) = 0 And ComboBox3 <> 0 Then
 MsgBox "Sorry, " & TextBox5 & " not found!"
    Else
If TextBox9.Value = "" And ComboBox3.Value <> "" Then
        MsgBox "There is no data to add", 48
    Else
  
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox4, ws.Range("6:6"), TextBox4) = 0 And ComboBox4 <> 0 Then
 MsgBox "Sorry, " & TextBox4 & " not found!"
    Else
If TextBox10.Value = "" And ComboBox4.Value <> "" Then
        MsgBox "There is no data to add", 48
    Else
  
If WorksheetFunction.CountIfs(ws.Range("6:6"), TextBox7, ws.Range("6:6"), TextBox7) = 0 And ComboBox5 <> 0 Then
 MsgBox "Sorry, " & TextBox7 & " not found!"
    Else
If TextBox11.Value = "" And ComboBox5.Value <> "" Then
        MsgBox "There is no data to add", 48
    Else

For i = 5 To N
    If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox1.Value Then
        ActiveSheet.Cells(i, Rng1.Column).Value = frmAddAdj.TextBox3.Text
    End If
  
    If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox2.Value Then
        ActiveSheet.Cells(i, Rng2.Column).Value = frmAddAdj.TextBox8.Text
    End If
  
    If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox3.Value Then
        ActiveSheet.Cells(i, Rng3.Column).Value = frmAddAdj.TextBox9.Text
    End If
  
    If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox4.Value Then
        ActiveSheet.Cells(i, Rng4.Column).Value = frmAddAdj.TextBox10.Text
    End If
  
    If ActiveSheet.Cells(i, "B").Value = frmAddAdj.ComboBox5.Value Then
        ActiveSheet.Cells(i, Rng5.Column).Value = frmAddAdj.TextBox11.Text
    End If
Next i

End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End Sub


Private Sub CommandButton2_Click()


Unload frmAddAdj



End Sub

Private Sub CommandButton3_Click()
Dim ctl As MSForms.Control

    For Each ctl In Me.Controls
        Select Case TypeName(ctl)
            Case "TextBox", "ComboBox"
                ctl.Text = ""
            Case "CheckBox", "OptionButton", "ToggleButton"
                ctl.Value = False
        End Select
    Next ctl
End Sub

Private Sub UserForm_Initialize()

Dim iRow As Integer, iMax As Integer

iRow = Cells.Find(What:="New Jersey Audit Adjustment", _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Row

iMax = Cells.Find(What:="New Jersey Audit Adjustment", _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
    MatchCase:=False, SearchFormat:=False).Row
  
If ActiveSheet.Range("B" & iRow & ":B" & iMax).Cells.Count = 1 Then
    Me.ComboBox1.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox2.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox3.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox4.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox5.AddItem ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
  
Else
    Me.ComboBox1.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox2.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox3.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox4.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
    Me.ComboBox5.List = ActiveSheet.Range("B" & iRow & ":B" & iMax).Value
  
End If
End Sub


This is the code to delete members

VBA Code: 
Private Sub CommandButton1_Click()

'declare the variables
    Dim Findvalue As Range, DeleteRange As Range
    Dim Response As VbMsgBoxResult
    Dim cNum As Integer
    Dim Search As String, FirstAddress As String
    Dim ws As Worksheet
  
  
    Set ws = ThisWorkbook.Sheets("DATA Member-19")

  
'error statement
    On Error Resume Next
  
    Search = TextBox6.Value
'check for control from listbox dblclick values
    If TextBox6.Value = "" Or Search = "" Then
        MsgBox "There is not data to delete", 48
        Exit Sub
    Else
'find the employees number row
        Set Findvalue = ws.Range("D:D").Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Findvalue Is Nothing Then
'mark first address
        FirstAddress = Findvalue.Address
'give the user a chance to change their mind!
            Response = MsgBox(Search & Chr(10) & _
            "Are you sure that you want to delete this Member?", 292, "Are you sure?")
            If Response = vbYes Then
'find all matching records
            Do
                If DeleteRange Is Nothing Then
                    Set DeleteRange = Findvalue
                Else
                    Set DeleteRange = Union(DeleteRange, Findvalue)
                End If
            Set Findvalue = ws.Range("D:D").FindNext(Findvalue)
            Loop While FirstAddress <> Findvalue.Address
          
'delete record(s)
            DeleteRange.EntireRow.Delete
              
'clear the user form controls
                cNum = 12
                For x = 1 To cNum
                    Me.Controls("Reg" & x).Value = ""
                Next
              
'Employee deleted from the database
                MsgBox Search & Chr(10) & "The Member has been deleted successfully.", 64, "Record Deleted"
              
'add the values to the listbox
               lstLookup.RowSource = ""
              
            End If
        Else
            MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
        End If
    End If

End Sub
Private Sub CommandButton2_Click()

Unload frmDeleteMembers19


End Sub


This is the code that goes into the main sheet module

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
                                                                                                                                           
    Dim KeyCells As Range, colNum As Long
    Dim ws As Worksheet

    Application.ScreenUpdating = False
  
        SOMESHEETS = "*C-Proposal-19*MemberInfo-19*Schedule J-19*NOL-19*NOL-P-19*NOL-PA-19*Schedule R-19*Schedule A-3-19*Schedule A-19*Schedule H-19*"
        Set KeyCells = Range("B30")
        If Not Application.Intersect(KeyCells, Target) Is Nothing Then
            If IsNumeric(KeyCells.Value) Then
                colNum = KeyCells.Value
                If colNum > 0 Then
                 For Each ws In ThisWorkbook.Worksheets
                     If ws.Visible = xlSheetVisible Then
                     If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
                            InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
                     End If
                     End If
                 Next ws
                End If
            End If
        End If
      

  
    SOMESHEETS = "*MemberInfo-20*C-Proposal-20*Schedule J-20*NOL-20*Schedule R-20*NOL-P-20*SchA-3-20*Schedule H-20*NOL-PA-20*Schedule A-20*Schedule A-5-20*"
    Set KeyCells = Range("B36")
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        If IsNumeric(KeyCells.Value) Then
            colNum = KeyCells.Value
            If colNum > 0 Then
                For Each ws In ThisWorkbook.Worksheets
                    If ws.Visible = xlSheetVisible Then
                    If CBool(InStr(LCase(SOMESHEETS), LCase("*" & ws.Name & "*"))) Then
                            InsertColumnsOnSheet argSheet:=ws, argColNum:=colNum
                    End If
                    End If
                Next ws
            End If
        End If
    End If
  
    Application.ScreenUpdating = True
End Sub


And this is the general code that each sheet pulls from. I only included on sheet to save some space, but each sheet has similar code.

VBA Code: 
Public Sub InsertColumnsOnSheet(ByVal argSheet As Worksheet, ByVal argColNum As Long)

    Dim Rng As Range, c As Range
    Dim TotalCol As Long, LeftFixedCol As Long
    Dim i As Long
    Dim ws As Worksheet
    Dim j As Integer, k As Integer

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

  
Set ws = Worksheets("C-Proposal-19")
    With argSheet
        Set Rng = .Range(.Cells(3, 6), .Cells(3, .Columns.Count))
        Set c = Rng.Find("GROSS")
        If Not c Is Nothing Then
            TotalCol = c.Column
            LeftFixedCol = 5
            j = .Range("B4").End(xlToRight).Column
            k = j - LeftFixedCol
            If ws.Visible = xlSheetVisible Then
            If TotalCol < LeftFixedCol + argColNum + 1 Then
                    .Columns(j).Copy
                    .Columns(j + 1).Resize(, argColNum - k).Insert CopyOrigin:=xlFormatFromLeftOrAbove
                        Application.CutCopyMode = False
            End If
            End If
            If TotalCol > LeftFixedCol + argColNum + 1 Then
                For i = TotalCol - 1 To LeftFixedCol + argColNum + 1 Step -1
                    .Columns(i).Delete
                Next i
            End If
        End If
    End With

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub


EDIT:
To add to the OP, if I add a member and refresh the keycells range, a new column will be added. If I then try to reduce the amount of columns manually, it will reduce the amount of columns. The issue pops up when I try use the delete macro. After I delete out the member through that macro, I cannot add or delete columns, either manually or through the refresh macro
 
Last edited by a moderator:

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
UPDATE:

There also seems to be an issue where if I have an error pop up with VBA, the workbook does not use the code that I have in it. For example, if I change the general code to add/delete columns and I get an error, even if I reset the VBA in the editor, if I try and change the keycells nothing happens. I don't get the same error again, even though I don't change the code at all, and nothing happens to any of the sheets.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
328
mumps
mumps
H
  • Question Question
VBA Code Problem
2 3
Replies
21
Views
267
Alex Blakenburg
A
B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
345
bdt
B
S
  • Solved
Diagonal Sum in excel table via VBA code
2
Replies
11
Views
511
myall_blues
myall_blues
M
  • Question Question
VBA Subtotal 47,000+ Rows
Replies
1
Views
259
igold
igold

Forum statistics

Threads
1,224,862
Messages
6,181,463
Members
453,043
Latest member
Sronquest

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top