sspatriots
Well-known Member
- Joined
- Nov 22, 2011
- Messages
- 585
- Office Version
- 365
- Platform
- Windows
The code that I use to insert my new row range into my table is shown below. It is triggered by a command button on my worksheet. I'm trying to insert a column called "Stock Item". I need checkboxes down that column that are centered both vertically and horizontally all the way down that column. I typically used structured reference when referring to my columns. If someone could just assist with getting this to work referring to the column letter "L" or column number, I can probably mange the rest. Thanks in advance for any advice here.
BTW: This code runs very slow and I'm wondering if there is a place it that I could turn off events and then turn back on later in the code to speed it up, because I do have some worksheet change events that run every time a targeted cell in the range is affected. I've added those event codes to the end.
Event code on worksheet named "2024"
BTW: This code runs very slow and I'm wondering if there is a place it that I could turn off events and then turn back on later in the code to speed it up, because I do have some worksheet change events that run every time a targeted cell in the range is affected. I've added those event codes to the end.
VBA Code:
Sub InsertRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim tb As ListObject
Dim NewRow As ListRow
Dim Start_No As String
Dim End_No As String
Dim PO_YR As String 'Added SPS, 09/23/22
Dim c As Range 'Added SPS, 09/23/22
Dim X As Long
Dim Resp1 As String
Dim Resp2 As String
Set wb = ThisWorkbook
Set ws = ThisWorkbook.ActiveSheet 'Sheets("2022")
' assumes Table is the first one on the ActiveSheet
'''''''''''''''''''''''''''''''''''''''
' Assign a variable to hold our table
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set tb = ActiveSheet.ListObjects(1)
' Set tb = ws.ListObjects("Table46")
Resp1 = MsgBox("Starting a New Year Worksheet Tab?", vbCritical + vbYesNo)
If Resp1 = vbYes Then
Resp2 = MsgBox("READ THE FOLLOWING COMPLETELY (then select 'OK' to clear this message and select 'EXIT' when the PO Block Maintenance form reappears) :" & vbCrLf & "" & vbCrLf & "Prior to selecting 'OK', Please write down or remember the following instructions:" _
& vbCrLf & "" & vbCrLf & "(1) First create a new worksheet by copying the previous year's worksheet and renaming it to the New Year." _
& vbCrLf & vbCrLf & "(2) Add the 'PO Year' and the 1st 'PO#' of the allocated block in the first row of a completely blank, one row table." _
& vbCrLf & vbCrLf & "(3) Select the 'Add PO No(s)' button again (from the 'PO Block Maintenance' Form, answer 'No' to the Pop-up Message Box and answer the next Pop-Up Message Box " _
& vbCrLf & "using the 2nd 'PO#' of the allocated block. Select 'OK'. Enter the last 'PO#' of the allocated block in the next Pop-Up Message Box. Select 'OK'.", vbExclamation)
If Resp2 = vbOK Then
GoTo ErrHandler
Else
End If
Else
End If
Start_No = InputBox("Enter Starting PO Number in Block")
End_No = InputBox("Enter Ending PO Number in Block")
On Error GoTo ErrHandler
Pleasewait.Show vbModeless
DoEvents
With Application
.DisplayAlerts = False 'Turns off alerts
' .AlertBeforeOverwriting = False 'Turns off overwrite alerts
.ScreenUpdating = False 'Turns off screen updating
End With
With tb.Range.Columns(3) 'column_to_check is relative to the tb.Range
Set c = .Find(What:="*", After:=.Cells(1), LookIn:=xlValues, _
SearchOrder:=xlByRows, searchdirection:=xlPrevious)
End With
With tb
For X = Start_No To End_No
Set NewRow = .ListRows.Add
NewRow.Range.Cells(3) = c 'This is the Year that gets copied all the way down
NewRow.Range.Cells(4) = X
Next X
Set NewRow = Nothing
End With
'ActiveSheet.ListObjects("Table46").Range.Select
tb.Range.Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Application.Calculation = xlCalculationAutomatic
POBlockHistorySortOnColA
Unload Pleasewait
MsgBox "Your New PO Numbers have been added to the PO Block History File.", vbInformation
Dim address_string As String, display_string As String
Dim cell As Range
For Each cell In tb.ListColumns("PO#").DataBodyRange
If cell.Value = Start_No Then
cell.Activate
End If
Next cell
ActiveWindow.ScrollRow = ActiveCell.Row
ActiveWindow.ScrollColumn = 1
With Application
.DisplayAlerts = True 'Turns on alerts
' .AlertBeforeOverwriting = False 'Turns off overwrite alerts
.ScreenUpdating = True 'Turns on screen updating
End With
ErrHandler:
End Sub
Event code on worksheet named "2024"
VBA Code:
Option Explicit
Dim Oldvalue As String
Dim Newvalue As String
Dim oldAddress As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sSheetName As String
'Dim temparr(1 To 1, 1 To 3) As Variant 'DELETE LATER IF THIS HAS NO IMPACT, SPS, 10/04/23
Dim r As Long
'*********DECLARED VARIABLES FOR ADDING ITEMS TO DROP-DOWN LIST STARTS HERE, SPS, 10/05/23*********
Dim cl As Range
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim Rng As Range
Dim lCol As Long
Dim myRsp As Long
Dim My_Value As String
Dim My_HValue As String 'Added, SPS, 10/04/22
Dim strList As String
'*********DECLARED VARIABLES FOR ADDING ITEMS TO DROP-DOWN LIST STOPS HERE, SPS, 10/05/23*********
On Error GoTo Exitsub
If Not Intersect(Target, Range("L:L")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & vbNewLine & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C:K,M:P")) Is Nothing Then Exit Sub
' MsgBox "Passed!" '<- added for testing
' If Target.Count = 1 Then oldValue = Target.Value
oldAddress = Target.Address
sSheetName = ActiveSheet.Name
r = ActiveCell.Row
If ActiveSheet.Name <> "LogDetails" Then
Application.EnableEvents = False
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Oldvalue
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
'THIS CODE POPULATES THE CELLS THAT GET SENT OUT WHEN HILLARY SENDS OUT ALL THE PO BLOCK HISTORY UPDATES, SPS, 10/05/23
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = ActiveSheet.Range("A" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = ActiveSheet.Range("E" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 8).Value = ActiveSheet.Range("G" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 9).Value = ActiveSheet.Range("H" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 10).Value = ActiveSheet.Range("I" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 11).Value = ActiveSheet.Range("K" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 12).Value = ActiveSheet.Range("L" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 13).Value = ActiveSheet.Range("M" & r)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 14).Value = ActiveSheet.Range("N" & r)
'ADD THE BACK LINK
Sheets("LogDetails").Hyperlinks.Add Anchor:=Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", _
SubAddress:="'" & sSheetName & "'!" & oldAddress, TextToDisplay:=oldAddress
Sheets("LogDetails").Columns("A:E").AutoFit
Application.EnableEvents = True
'CODE TO ENABLE ADDING ITEMS TO DROP-DOWN LIST STARTS HERE, SPS, 10/05/23
On Error Resume Next
Set ws = Worksheets("Drops") 'Changed "Lists" to "Drops", SPS, 09/26/22
If Target.Row > 1 Then
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then Exit Sub
If Intersect(Target, rngDV) Is Nothing Then Exit Sub
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
On Error Resume Next
Set Rng = ws.Range(str)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
If Application.WorksheetFunction _
.CountIf(Rng, Target.Value) Then
Exit Sub
Else
My_Value = Target.Value 'Added, SPS, 09/26/22
My_HValue = Target.Offset(2 - Target.Row).Value 'Added, SPS, 10/04/22
myRsp = MsgBox("Add '" & My_Value & "' to the '" & My_HValue & "' drop down list?", _
vbQuestion + vbYesNo + vbDefaultButton1, _
"New Item -- not in drop down")
If myRsp = vbYes Then
lCol = Rng.Column
i = ws.Cells(Rows.Count, lCol).End(xlUp).Row + 1
ws.Cells(i, lCol).Value = Target.Value
strList = ws.Cells(1, lCol).ListObject.Name
With ws.ListObjects(strList).Sort
.SortFields.Clear
.SortFields.Add _
Key:=Cells(2, lCol), _
SortOn:=xlSortOnValues, _
Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ws.ListObjects(strList)
.Resize .DataBodyRange.CurrentRegion
End With
End If
End If
End If
'CODE TO ENABLE ADDING ITEMS TO DROP-DOWN LIST STOPS HERE, SPS, 10/05/23
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C:P")) Is Nothing Then Exit Sub 'ADDED TO TEST, SPS, 06/09/2023
Oldvalue = Target.Value
End Sub