Insert/Delete Columns via VBA issue - excel

Question

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 (based on changing the keycells value), 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 the VBA, I cannot continue working in it. I can maneuver throughout the file, however, adding or deleting columns (by any means) does not work. It's as though, even though the VBA was reset in the editor, the code does not exist.
This is the code that is used to refresh the keycell
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
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
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
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.
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
Moreover, 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.
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.

Answer 1

There is a bug in the first part of your code:
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
This shows the problem:
Dim ws As Worksheet, e
For Each e In Array("Sheet1", "Sheet2")
On Error Resume Next
Set ws = ThisWorkbook.Sheets(e)
On Error GoTo 0
If Not ws Is Nothing Then Debug.Print e, ws.Name
Next e
Run in a workbook which contains only Sheet1, it gives this output:
Sheet1 Sheet1
Sheet2 Sheet1 'oops!
So you need to add Set dws = Nothing before running Set dws = wb.Worksheets(dwsNames(d))