VBA_通过根据匹配文本在单元格之间插入行来填充用户窗体数据

Question

在我的excel文档中，我具有以下信息：

我想自动将我的用户表单数据填充到新行（在单元格之间），因此当我们在用户表单TextBox中键入“来自备注的文本”列时，它会自动找到匹配项并将数据填充到“文本”下方的新行中从备注”。

示例：当我在用户窗体Texbox中输入“ Hys（第4行）”时，代码应找到“ Hys”并在“ Hys”下用新行（第5行）传输新数据，并且当输入新数据。

必需的输出，如下图所示：

我尝试使用下面的代码，但无法获得所需的输出，我能够将单元格移至新行，但不能插入新行。

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

Answer 1

在匹配文本后在行中插入控件值

假设您想在引用的 Remark 代码（加上列偏移量1）之后的每一行正好每次插入当前文本框值，那么问题是您有

• a）插入整行和
• b）也会将此目标偏移1行。

此外，我演示了[2]节的一种替代方法，该方法如何使用数组写入所有值，而不是分别分配每个TextBox值-c.f。胜过[2a]部分。

BTW尽量避免使用大多数不必要的.Activate和.Select方法；您通过完全限定范围和图纸参考的正确性来做到了这一点（无论如何，对有效参考毫无疑问）。

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