VBA_Populate userform data by insert rows in between cells based on the Matching text

问题

In my excel document I have the following Information:

I want to automatically populate my userform data to new rows(in between cells), so when we type "Text from Remark" column in the userform TextBox it automatically Find the match and populate data in a new row below the "Text from Remark".

Example: When I enter "Hys(row 4)" in the Userform Texbox, the Code should find "Hys" and Transfer the new data below "Hys" with a new row(row 5) and the same repeated again when new data is entered.

Required Output as shown in below Image:

I have tried with below Code but not able to get the required outpiut , I was able to shift the cells to new rows but not inserting new rows.

Private Sub cmdadd_Click()

    Dim fvalue As Range
    Dim wks As Worksheet
    Set wks = ThisWorkbook.Worksheets("Sheet1")
    wks.Activate
    Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
    fvalue.Value = Me.txtremark.Value
    fvalue.Insert shift:=xlDown
    fvalue.Offset(0, 1).Value = Me.txtplace.Value
    fvalue.Offset(0, 2).Value = Me.txtstart.Value
    fvalue.Offset(0, 3).Value = Me.txtend.Value

End Sub

回答1:

Inserting control values in row after matching text

Assuming you want to insert the current text box values each time precisely one row after the referring Remark code (plus column offset of 1), your issue was that you have

a) to insert an entire row and
b) to offset this target by 1 row, too.

Furthermore I demonstrate an alternative to section [2] how to write all values using an array instead of assigning each TextBox value separately - c.f. outcommented section [2a].

BTW try to avoid using the mostly unnecessary .Activate and .Select methods; you did it right by fully qualifying your range and sheet references (letting no doubt about the active reference anyway).


Private Sub cmdadd_Click()
    Dim fvalue As Range
    Dim wks    As Worksheet
    Set wks = ThisWorkbook.Worksheets("Sheet1")
    Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
    If fvalue Is Nothing Then
    ' do something if nothing found
    ' (e.g. add new title rows and reset fvalue OR Exit Sub displaying a message)
    ' ...
    End If

      ' [1] insert a) ENTIRE row b) ONE row (=offset 1) after the found remark cell
        fvalue.Offset(1).EntireRow.Insert shift:=xlDown

      ' [2] write values to newly inserted row, i.e. 1 row after found cell
        fvalue.Offset(1, 1).Value = Me.txtplace.Value
        fvalue.Offset(1, 2).Value = Me.txtstart.Value
        fvalue.Offset(1, 3).Value = Me.txtend.Value

      '' [2a] or alternatively with less code lines using an array with all values:
      '   Dim arr()
      '   arr = Array(Me.txtplace, Me.txtstart, Me.txtend)
      '   fvalue.Offset(1, 1).Resize(1, UBound(arr) + 1) = arr

    End If
End Sub

来源：https://stackoverflow.com/questions/57097786/vba-populate-userform-data-by-insert-rows-in-between-cells-based-on-the-matching

标签

excel

vba

userform