Need code that adds multiple new rows to table to include a check box in column "L" for each new row

sspatriots

Well-known Member
Joined
Nov 22, 2011
Messages
585
Office Version
  1. 365
Platform
  1. 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.



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
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

Forum statistics

Threads
1,223,859
Messages
6,175,036
Members
452,606
Latest member
jkondrat14

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