Excel VBA如何将Textbox2输入的员工号写入粘贴数据同行的H列

修改逻辑 #

你现有代码中已经通过dfCell定位到了本次粘贴数据的目标行起始单元格（目标工作表A列对应行），只需要在数据写入目标区域后，单独给该行H列赋值TextBox2的内容即可，无需修改原有核心逻辑。

具体修改点 #

在原代码drg.Value = dData 行之后、删除源行代码之前，添加一行赋值代码即可，完整修改后的代码如下：

Option Explicit
Private Sub CommandButton2_Click()

Const sName As String = "LS - Huawei"
Const sFirst As String = "A6"
Const sColsList As String = "B,C,D,E,F,H,J" '如果不需要保留源表H列数据，可删除列表中的H

Const dName As String = "Personalesalg"
Const dFirst As String = "A6"

Dim wb As Workbook: Set wb = ThisWorkbook
Dim Criteria As String: Criteria = Textbox1.Value

' 创建源表查询列引用
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
Dim slCell As Range
Set slCell = sfCell.Resize(sws.Rows.Count - sfCell.Row + 1) _
    .Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then
    MsgBox "Tom kolonne i source"
    Exit Sub
End If
Dim slrg As Range: Set slrg = sws.Range(sfCell, slCell)
Debug.Print "Source Lookup Range:          " & slrg.Address

' 创建源表匹配行整行引用
Dim rIndex As Variant: rIndex = Application.Match(Criteria, slrg, 0)
If IsError(rIndex) Then
    MsgBox "ID kan ikke findes"
    Exit Sub
End If
Dim srrg As Range: Set srrg = slrg.Cells(rIndex).EntireRow
Debug.Print "Source (Entire) Row Range:    " & srrg.Address

' 创建源表需要提取的列引用
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim nUpper As Long: nUpper = UBound(sCols)
Dim scrg As Range
Dim n As Long
For n = 0 To UBound(sCols)
    If scrg Is Nothing Then
        Set scrg = sws.Columns(sCols(n))
    Else
        Set scrg = Union(scrg, sws.Columns(sCols(n)))
    End If
Next n
Debug.Print "Source (Entire) Column Range: " & scrg.Address

' 创建源表待复制区域引用
Dim srg As Range: Set srg = Intersect(srrg, scrg)
Debug.Print "Source Row Range:             " & srg.Address

' 定义目标数组
Dim cCount As Long: cCount = srg.Cells.Count
Dim dData As Variant: ReDim dData(1 To 1, 1 To cCount)

' 把源表数据写入目标数组
Dim sCell As Range
Dim c As Long
For Each sCell In srg.Cells
    c = c + 1
    dData(1, c) = sCell.Value
Next sCell

' 定位目标表粘贴起始单元格
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim difCell As Range: Set difCell = dws.Range(dFirst)
Dim dCell As Range
Set dCell = difCell.Resize(dws.Rows.Count - difCell.Row + 1) _
    .Find("*", , xlFormulas, , , xlPrevious)
Dim dfCell As Range
If dCell Is Nothing Then
    Set dfCell = difCell
Else
    Set dfCell = dCell.Offset(1)
End If

' 创建目标表粘贴区域引用
Dim drg As Range: Set drg = dfCell.Resize(, cCount)
Debug.Print "Destination Range:            " & drg.Address

' 把数组数据写入目标表
drg.Value = dData

' ==========新增代码 写入员工号到当前行H列==========
dws.Cells(dfCell.Row, "H").Value = TextBox2.Value
' ==========新增代码结束==========

' 删除源表对应行
srrg.Delete

MsgBox "Done."
Unload UserForm2

注意事项 #

• 如果你不需要保留源表H列的原有数据，可直接修改常量sColsList的值，删除其中的H，避免源数据覆盖你写入的员工号
• 注意检查TextBox2控件名称拼写是否正确，避免出现变量未定义的报错

内容的提问来源于stack exchange，提问作者Spoddi