我需要能够在Textbox2中键入员工编号(M-编号(。该员工编号应写在H列中，与下面的代码位于同一行。
经过多次尝试，我只能在下一个可用行中插入textbox2值，但不能在同一行中插入。
非常感谢您的帮助。
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"
Const dName As String = "Personalesalg"
Const dFirst As String = "A6"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Criteria As String: Criteria = Textbox1.Value
' Create a reference to the Source Lookup (Column) Range.
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
' Create a reference to the Source (Entire) Row Range.
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
' Create a reference to the Source (Entire) Columns Range.
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
' Create a reference to the Source (Row) Range.
Dim srg As Range: Set srg = Intersect(srrg, scrg)
Debug.Print "Source Row Range: " & srg.Address
' Define the Destination Array.
Dim cCount As Long: cCount = srg.Cells.Count
Dim dData As Variant: ReDim dData(1 To 1, 1 To cCount)
' Write the values from the Source (Row) Range to the Destination Array.
Dim sCell As Range
Dim c As Long
For Each sCell In srg.Cells
c = c + 1
dData(1, c) = sCell.Value
Next sCell
' Create a reference to the Destination First Cell Range.
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
' Create a reference to the Destination Range.
Dim drg As Range: Set drg = dfCell.Resize(, cCount)
Debug.Print "Destination Range: " & drg.Address
' Write the values from the Destination Array to the Destination Range.
drg.Value = dData
' Delete the entire row i.e. Source (Entire) Row Range.
srrg.Delete
MsgBox "Done."
Unload UserForm2
这是它需要做的大量代码-我会简化并跳过整个"复制为数组"；部分当然它有点快，但你不会注意到差异，你只需要维护大量的代码。。。
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" '<<edited here
Const dName As String = "Personalesalg"
Const dFirst As String = "A6"
Dim wb As Workbook, Criteria As String, m, sws As Worksheet, sfCell As Range
Dim slrg As Range, destCell As Range, arrCols, col
Set wb = ThisWorkbook
Criteria = Textbox1.Value
Set sws = wb.Worksheets(sName) 'source sheet
Set sfCell = sws.Range(sFirst) 'EDIT - was missing this line
Set slrg = sws.Range(sFirst, sws.Cells(Rows.Count, sfCell.Column))
Debug.Print "Source Lookup Range: " & slrg.Address
m = Application.Match(Criteria, slrg, 0)
If Not IsError(m) Then
'get the first destination cell
Set destCell = NextEmptyCell(wb.Worksheets(dName).Range(dFirst))
arrCols = Split(sColsList, ",")
With sws.Rows(m)
For Each col In arrCols
destCell.Value = .Columns(col).Value
Set destCell = destCell.Offset(0, 1)
Next col
destCell.Value = Textbox2.Value '<< edit: populate ColH
.Delete
End With
Else
MsgBox "No match found for '" & Criteria & "'"
End If
Unload Me 'Me in a userform refers to the form itself
End Sub
'find the cell below the last populated cell in the same column as `startCell`
' if no cell are populated then return `startCell`
Function NextEmptyCell(startCell As Range) As Range
Dim f As Range
With startCell.Parent
Set f = .Range(startCell, .Cells(.Rows.Count, startCell.Column)) _
.Find("*", , xlFormulas, , , xlPrevious)
End With
If Not f Is Nothing Then
Set NextEmptyCell = f.Offset(1, 0)
Else
Set NextEmptyCell = startCell
End If
End Function