VBA/Macro to insert rows based on drop downlist selection|VBA & Macros|Excel Forum|My Online Training Hub

Good morning everyone,

I apologize for the delay on this topic, without much time available

I didn't understand everything you wanted, but here is an example with some parts that I understood

I attached a file

Option Explicit

Dim nextStepProgram As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)

Dim intRowCount As Integer

If nextStepProgram = False Then
     nextStepProgram = True
     intRowCount = CheckNumb
     Call Update_DataValidation(intRowCount)
     nextStepProgram = False
End If

Call getAllCellsWithValidation

End Sub

Private Function CheckNumb() As Integer

Dim i As Integer
Dim nextStep As Boolean

i = 1
nextStep = True

While nextStep = True
     If Cells(i, 1) <> "" Then
         i = i + 1
     Else
         nextStep = False
     End If
Wend

CheckNumb = i - 1

End Function

Private Sub Update_DataValidation(ByVal intRow As Integer)

Dim LastRow As Long
Dim ws As Worksheet
Dim range1 As Range, Rng As Range

Application.ScreenUpdating = False

Set ws = Application.ThisWorkbook.Worksheets("Folha2")

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow

Set Rng = ws.Range("A1:A" & LastRow)
Rng.RemoveDuplicates Columns:=1, Header:=xlNo

Set range1 = ws.Range("A1:A" & LastRow)

With Sheet1.Range("J2").Validation
     .Delete
     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
     Operator:=xlBetween, Formula1:="='" & ws.Name & "'!" & range1.Address
     .IgnoreBlank = True
     .InCellDropdown = True
     .InputTitle = ""
     .ErrorTitle = ""
     .InputMessage = ""
     .ErrorMessage = ""
     .ShowInput = True
     .ShowError = True
End With

Application.ScreenUpdating = True

End Sub

Private Sub getAllCellsWithValidation()

Dim cell As Range, v As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim xcell As String
Dim ArrInput() As Integer, i As Integer
Dim x As Integer
Dim xrange As Range
Dim a As Integer

Application.ScreenUpdating = False

Set ws = Application.ThisWorkbook.Worksheets("Folha1")

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow

Set xrange = ws.Range("J1:J" & LastRow)

On Error Resume Next
ReDim ArrInput(0)
On Error GoTo 0
i = 0

For Each cell In xrange.Cells
     v = 0
     On Error Resume Next
     v = cell.SpecialCells(xlCellTypeSameValidation).Count
     On Error GoTo 0

     If v = 0 Then
         ' MsgBox "No validation!"
     Else
         ' MsgBox "Has validation!"
         ' x = x & vbCrLf & cell.Address
         ' x = x & vbCrLf & cell.Row
         xcell = cell.Row
         ArrInput(i) = xcell
         i = i + 1
         ReDim Preserve ArrInput(i)

     End If
Next cell

If i = 0 Then Exit Sub

With Application.ThisWorkbook.Worksheets("Folha1")

For x = LBound(ArrInput) To UBound(ArrInput)
     a = ArrInput(x)
     If a <> 0 Then
         If ActiveCell.Column = 10 And ActiveCell.Row = a Then
             If ActiveCell.Value <> "" Then
                     Call addNewRowWithDropDownList(a)
             Else
                 'Cancel is true
             End If
         Else
             'Cancel is true
         End If
     End If
Next x

End With

Application.ScreenUpdating = True

End Sub

Private Sub addNewRowWithDropDownList(rNum As Integer)

Dim RowNum As Integer
Dim LastRow As Long, LastRow2 As Integer
Dim ws As Worksheet
Dim range1 As Range, Rng As Range
Dim x As Integer

Application.ScreenUpdating = False

Set ws = Application.ThisWorkbook.Worksheets("Folha2")

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow

Set Rng = ws.Range("A1:A" & LastRow)
Rng.RemoveDuplicates Columns:=1, Header:=xlNo

Set range1 = ws.Range("A1:A" & LastRow)

RowNum = Application.ThisWorkbook.Worksheets("Folha1").Range("J" & rNum).Cells.Row
If RowNum = 0 Then Exit Sub

Range("J1").Offset(RowNum, 0).Select
x = Range("J1").Offset(RowNum, 0).Cells.Row

LastRow2 = Application.ThisWorkbook.Worksheets("Folha1").Cells(Application.ThisWorkbook.Worksheets("Folha1").Rows.Count, "A").End(xlUp).Row
Debug.Print LastRow2

'Application.ThisWorkbook.Worksheets("Folha1").Range("A" & x & ":" & "A" & x + 2).EntireRow.Insert
'Application.ThisWorkbook.Worksheets("Folha1").Range("J" & x).Select

With Application.ThisWorkbook.Worksheets("Folha1")
     .Range("A" & LastRow2 + 1 & ":" & "A" & LastRow2 + 3).EntireRow.Insert
     .Range("A" & LastRow2 + 1).Value = "info line 1"
     .Range("A" & LastRow2 + 2).Value = "info line 2"
     .Range("A" & LastRow2 + 3).Value = "info line 3"
     .Range("A" & LastRow2 + 1 & ":" & "M" & LastRow2 + 1).Borders(xlEdgeTop).LineStyle = xlContinuous
     .Range("A" & LastRow2 + 3 & ":" & "M" & LastRow2 + 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
     .Range("A" & LastRow2 + 1 & ":" & "A" & LastRow2 + 3).Borders(xlEdgeLeft).LineStyle = xlContinuous
     .Range("M" & LastRow2 + 1 & ":" & "M" & LastRow2 + 3).Borders(xlEdgeRight).LineStyle = xlContinuous
     .Columns.AutoFit
     .Rows.WrapText = False
End With

Application.ThisWorkbook.Worksheets("Folha1").Range("J" & LastRow2).Select

With Selection.Validation
     .Delete
     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
     Operator:=xlBetween, Formula1:="='" & ws.Name & "'!" & range1.Address
     .IgnoreBlank = True
     .InCellDropdown = True
     .InputTitle = ""
     .ErrorTitle = ""
     .InputMessage = ""
     .ErrorMessage = ""
     .ShowInput = True
     .ShowError = True
End With

Application.ScreenUpdating = True

If Not ws Is Nothing Then Set ws = Nothing

With Application.ThisWorkbook.Worksheets("Folha1")
     .Select
     .Range("J" & LastRow2 + 1).Validation.Delete
     .Range("J" & LastRow2 + 2).Validation.Delete
End With

End Sub