Visual Basic: inserting rows, merging specific cells and adding specific text in excel

[thomassamoth]

Hello, this is my first time posting here.

My goal is as follows: I want to insert a specific amount of rows after I searched for a specific cell value and merge some of the columns of those inserted cells. I also want to add specific values to another column in the inserted cell. I know this sounds very vague, but at the end I added some pictures which will hopefully make things more clear. And before you comment that I shouldn't merge the cells, it's what my boss want so rip .

The process the of system (Inputboxes) would go as follows:

1. Which value are you looking for?
2. Select the range in where you want to look.
3. How many rows would you like to add?
4. Which value would you like to have in row [array#]?
5. Which columns would you like to merge with the inserted rows?

In excel, the process will look like this before:

and like this after:

As you can see, there are now 3 more rows inserted after "Car". The column "type", "Tag number" and "Cost" are now merged, while "tire number" has 3 new added values, namely "1", "2" and "3".


I already wrote a bit of code, which helps me to insert a dynamic amount of rows after I tell Excel for which cell value it needs to look. The problem is that I don't understand how I can set the range for the merge of the cells and how I can add specific values in specific cells for each row I add. Basically, I don't understand the "Range" function in Excel, because my brain is 90% Jelly.

Private Sub ToggleButton1_Click()Dim Rng As Range
    Dim WorkRng As Range
    On Error Resume Next
    
    inputSearch = InputBox("After which value would you like to add a row?")
    inputAmountOfRows = InputBox("How many Rows would you like to add?")
    inputColumnRangeCopy1 = InputBox("From which column would you like to start copying?")
    inputColumnRangeCopy2 = InputBox("From which column would you like to end copying?")
    
    
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Select Range", WorkRng.Address, Type:=8)
    Set WorkRng = WorkRng.Columns(1)
    
    
    xLastRow = WorkRng.Rows.Count
    Application.ScreenUpdating = False
    
    For xRowIndex = xLastRow To 1 Step -1
        Set Rng = WorkRng.Range("A" & xRowIndex)
        If Rng.Value = inputSearch Then
            For i = inputAmountOfRows To 1 Step -1
            Rng.Offset(1, 0).EntireRow.Insert Shift:=xlDown
                With Range(????)
                    .Merge
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlTop
                End With
            Next i
        End If
    Next xRowIndex
    
    Application.ScreenUpdating = True
    
    End Sub

 

[Legacy 143009]

Can you explain this?

4. Which value would you like to have in row [array#]?

Is it about "1, 2, 3, 4" thing? Are the numbers always consecutive?

 

[thomassamoth]

Can you explain this?

Is it about "1, 2, 3, 4" thing? Are the numbers always consecutive?

No, I wasn't clear in that, but the 1,2,3,4 thing represent the unique inputs from the inputboxes. I expended the code already:

    Dim searchTerm As String
    
    Dim columnLetter() As Variant
    Dim uniqueValues() As Variant

    Dim firstMatch As Range
    Dim searchRange As Range
    Dim Rng As Range
    
    Dim numRowsToInsert As Integer
    Dim numColumnsToChange As Integer
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim m As Integer
    
    'Main code
    
    searchTerm = InputBox("Enter the search term:")
    
    Set searchRange = Application.InputBox("Enter the range to search in:", Type:=8)
    
    numRowsToInsert = InputBox("Enter the number of rows to insert, which should contain a unique value:")
    
    numColumnsToChange = InputBox("Enter the amount of columns, which should contain a unique value:")
    
    ReDim columnLetter(1 To numColumnsToChange)
    For i = 1 To numColumnsToChange
        columnLetter(i) = InputBox("Enter the column letter for column " & i & " (e.g. A, B, C):")
    Next i
    
    ReDim uniqueValues(1 To numRowsToInsert, 1 To numColumnsToChange)
    For j = 1 To numRowsToInsert
        For k = 1 To numColumnsToChange
            uniqueValues(j, k) = InputBox("Enter unique cell value for cell " & columnLetter(k) & j & ": ")
        Next k
    Next j

 

[Legacy 143009]

Do you want a unique check at this point?

uniqueValues(j, k) = InputBox("Enter unique cell value for cell " & columnLetter(k) & j & ": ")

 

[thomassamoth]

Do you want a unique check at this point?

uniqueValues(j, k) = InputBox("Enter unique cell value for cell " & columnLetter(k) & j & ": ")

yes

 

[Legacy 143009]

OK, I will give this code a shot today. I have two last questions:
1. Does "unique value" thing apply to all columns? I don't think it applies to "Tag" and "Type" columns. Can user select "Price" and "Tire" columns only or both?
2. Do you want to merge the rows with the same value? You said your boss doesn't like but then there is merging in the code? What is your final decision?

 

[thomassamoth]

OK, I will give this code a shot today. I have two last questions:
1. Does "unique value" thing apply to all columns? I don't think it applies to "Tag" and "Type" columns. Can user select "Price" and "Tire" columns only or both?
2. Do you want to merge the rows with the same value? You said your boss doesn't like but then there is merging in the code? What is your final decision?

Hey, sorry for the late reply, since im not from the US.
1: yes it applies to all columns.
2: I believe most people don't recommend to merge, but my boss actually does want it.

 

[thomassamoth]

I had some more time to adjust the code. I succeeded to add # amount of lines after the search result, but I'm not able to insert a new value in the cells I specified. I haven't tried to merge the cells yet. Here is the code:

Private Sub ToggleButton1_click()
    'Variables
    Dim searchTerm As String
    Dim myString As String
    
    Dim columnLetter() As Variant
    Dim uniqueValues() As Variant

    Dim searchRange As Range
    Dim Cell As Range
    Dim newRow As Range
    
    Dim numRowsToInsert As Integer
    Dim numColumnsToChange As Integer
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    
    Dim m As Long
    
    Dim n As Integer
    Dim o As Integer
        
    Dim lastRow As Long
    
    'Main code
    searchTerm = InputBox("Enter the search term:")
    
    Set searchRange = Application.InputBox("Enter the range to search in:", Type:=8)
    
    numRowsToInsert = InputBox("Enter the number of rows to insert, which should contain a unique value:")
    
    numColumnsToChange = InputBox("Enter the amount of columns, which should contain a unique value:")
    
    ReDim columnLetter(1 To numColumnsToChange)
    For i = 1 To numColumnsToChange
        columnLetter(i) = InputBox("Enter the column letter for column " & i & " (e.g. A, B, C):")
    Next i
    
    ReDim uniqueValues(1 To numRowsToInsert, 1 To numColumnsToChange)
    For j = 1 To numRowsToInsert
        For k = 1 To numColumnsToChange
            uniqueValues(j, k) = InputBox("Enter unique cell value for cell " & columnLetter(k) & j & ": ")
        Next k
    Next j
    
    lastRow = searchRange.Cells(searchRange.Cells.Count).Row
    
    Application.ScreenUpdating = False
    
    For m = lastRow To searchRange.Cells(1).Row Step -1
        If searchRange.Cells(m, 1).Value = searchTerm Then
            For n = 1 To numRowsToInsert
                Set newRow = searchRange.Rows(m + 1).EntireRow
                newRow.Insert Shift:=xlShiftDown
                On Error Resume Next
                For o = 1 To numColumnsToChange
                    newRow.Cells(1, columnLetter(o) & n).Value = uniqueValues(n, o)
                Next o
                On Error GoTo 0
            Next n
        End If
    Next m
    
    Application.ScreenUpdating = True
    
End Sub

 

[Legacy 143009]

Sample.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Sub test()
  Dim searchTerm As Variant, searchRange As Range, columnLetter As Variant, uniqueValues() As Variant, intersects As Boolean, t As Long
  searchTerm = Trim(InputBox("Enter the search term:"))
  Set searchRange = Application.InputBox("Enter the range to search in:", Type:=8)
  numRowsToInsert = InputBox("Enter the number of rows to insert, which should contain a unique value:")
  columnletters = Split(InputBox("Enter the column letters to be modified (e.g. A, B, C):"), ",")
  ReDim uniqueValues(0 To numRowsToInsert - 1, 0 To UBound(columnletters))
  
  For i = 0 To numRowsToInsert - 1
    For j = 0 To UBound(columnletters)
INPUTAGAIN:
      uniqueValues(i, j) = InputBox("Enter unique cell value for Column " & UCase(Trim(columnletters(j))) & " row " & i + 1 & ":")
      If uniqueValues(i, j) = "" Then
        MsgBox "Unique value can not be empty!"
        GoTo INPUTAGAIN
      End If
      For r = 0 To i - 1
        If uniqueValues(r, j) = uniqueValues(i, j) Then
          MsgBox "Please enter a unique value!"
          GoTo INPUTAGAIN
        End If
      Next
    Next
  Next
  With searchRange
  For r = Split(.Rows(.Rows.Count).Address, "$")(2) To 2 Step -1
    For c = 1 To Range(Split(.Columns(.Columns.Count).Address, "$")(1) & 1).Column
      If Not IsEmpty(Cells(r, c).Value) And UCase(Trim(Cells(r, c).Value)) = UCase(searchTerm) Then
        Rows(r).EntireRow.Copy
        Rows(r).Offset(1).Resize(numRowsToInsert).EntireRow.Insert shift:=xlDown
        For col = 1 To UsedRange.Columns.Count
          intersects = False
          For j = 0 To UBound(columnletters)
            If Not Intersect(Columns(Trim(columnletters(j))), Columns(col)) Is Nothing Then
              intersects = True
              t = j
            End If
          Next
          If Not intersects Then
            Application.DisplayAlerts = False
            Cells(r, col).Resize(numRowsToInsert + 1).Merge
            Application.DisplayAlerts = True
            Cells(r, col).Resize(numRowsToInsert + 1).HorizontalAlignment = xlCenter
            Cells(r, col).Resize(numRowsToInsert + 1).VerticalAlignment = xlCenter
          Else
            For i = 0 To numRowsToInsert - 1
              Cells(r + i + 1, col).Value = uniqueValues(i, t)
            Next
          End If
        Next
        GoTo NEXTRECORD
      End If
    Next
NEXTRECORD:
  Next
  End With
End Sub

 

[thomassamoth]

Thank you! This is exactly what I wanted! Much appreciated.