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]

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

Glad it did work! Thanks for the feedback

 

[thomassamoth]

The code works very good, but I noticed that for some rows, I want to select the columns which should merge, so one final request: Could you rewrite the code, so I am able to select which columns I want to merge and which one I won't? I'm honestly not skilled enough to do it myself I was also wondering if it would be possible to set an amount of columns I want to add. For the second question, it would look something like this (I think):

    numColumnsToChange = InputBox("Enter the amount of columns, which should contain a unique value:")
    numRowsToInsert = InputBox("Enter the number of rows to insert, 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

I hope it isn't to much of a hustle. Thanks in advance!

 

[Legacy 143009]

Sorry, adding columns will change everything. I have no time for this. For merging:

Sub test()
  Dim searchTerm As Variant, searchRange As Range, columnLetter As Variant, uniqueValues() As Variant, intersects As Boolean, t As Long, answer As Integer
  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
            answer = MsgBox("Do you want to merge Column " & Split(Columns(col).Address, "$")(1), vbQuestion + vbYesNo + vbDefaultButton2, "Warning")
            If answer = vbYes 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
            End If
          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]

Thanks for the help!

 

[Legacy 143009]

You are welcome