excel - Textbox2 值与当前代码在同一行

Question

我需要能够在 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

标签： excelvba

Answer 1

这是它需要做的很多代码 - 我会简化并跳过整个“复制为数组”部分。当然它会快一点，但你不会注意到差异，你只会得到更多的代码来维护......

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