通過拆分輸入文本并搜索匹配行，將匹配行剪切粘貼到另一個作業表

我有一個作業表“資料庫”，其中包含要搜索和洗掉的資料[剪切粘貼到另一個名為“已清除”的作業表]。所以我有一個輸入對話框，我將 FS Numbers 作為以逗號分隔的字串輸入，然后我使用Split()函式拆分文本以獲取數字。我曾經使用for loop與 FS 編號匹配的列來獲取單行。

我有我的 VBA 代碼

Sub DeleteRecord()


Dim iRow As Long
Dim iSerial As String
Dim DisplayText As String
Dim Result() As String
Dim i As Long


iSerial = Application.InputBox("Please enter FS Number to delete", "Delete", , , , , , 2)
'MsgBox (iSerial)
Result = Split(iSerial, ",")
'MsgBox Result(0)
'MsgBox Result(2)


On Error Resume Next
    For i = LBound(Result()) To UBound(Result())
        iRow = Application.WorksheetFunction.IfError(Application.WorksheetFunction.Match(Result(i), Sheets("Database").Range("B:B"), 0), 0)
        'MsgBox Result(i)
        Sheets("Database").Rows(iRow).Cut
        Worksheets("Cleared").Activate
        b = Worksheets("Cleared").Cells(Rows.Count, 2).End(xlUp).Row
        Worksheets("Cleared").Cells(b   1, 1).Select
        ActiveSheet.Paste
        Cells(b   1, 10).Value = [Text(now(),"DD-MM-YYYY HH:MM:SS")]
          
        Worksheets("Form").Activate
          
        Application.CutCopyMode = False
        ThisWorkbook.Worksheets("Form").Cells(1, 1).Select
        'MsgBox Result(i)
          
    Next i
      'For i = LBound(Result()) To UBound(Result())
      'DisplayText = DisplayText & Result(i) & vbNewLine
      'Next i
      'MsgBox DisplayText
   On Error GoTo 0
   
   If iRow = 0 Then
     MsgBox "No record found.", vbOKOnly   vbCritical, "No Record"
       Worksheets("Form").Activate
  ThisWorkbook.Worksheets("Form").Cells(1, 1).Select
   
     Exit Sub
     
     End If   
  
End Sub

當我運行代碼時，“已清除”作業表沒有任何價值。我哪里做錯了？

uj5u.com熱心網友回復：

移動記錄

Option Explicit

Sub MoveRecords()
    Const ProcTitle As String = "Move Records"
    
    ' Source
    Const sName As String = "Database"
    Const sFirst As String = "B2" ' First Cell of Serials
    ' Destination
    Const dName As String = "Cleared"
    Const dlrCol As String = "B"
    Const dTimeStampCol As String = "J"
    ' ???
    Const fName As String = "Form"
    ' Other
    Const Delimiter As String = "," ' ***
    Const TimeStampPattern As String = "dd-mm-yyyy hh:mm:ss"
    
    ' Get the input into an array.
    
    Dim SerialsList As Variant ' *** modify the prompt if not comma
    SerialsList = Application.InputBox( _
        "Please enter FS Numbers separated by a comma", ProcTitle, , , , , , 2)
    ' Cancel
    If SerialsList = False Then
        MsgBox "You canceled.", vbExclamation
        Exit Sub
    End If
    ' Ok but blank
    If Len(SerialsList) = 0 Then
        MsgBox "You didn't enter anything.", vbExclamation
        Exit Sub
    End If
    ' Ok
    Dim Serials() As String: Serials = Split(SerialsList, Delimiter)
    'Debug.Print Join(Serials, Delimiter)
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source 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 = sws.Cells(sws.Rows.Count, sfCell.Column).End(xlUp)
    Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
    
    Application.ScreenUpdating = False
    
    Dim sdrg As Range
    Dim sIndex As Variant
    Dim n As Long
     
    ' Loop throught the serials.
    For n = 0 To UBound(Serials)
        ' Attempt to find a match in the Source Range.
        ' Remove CLng() if strings in the cells.
        sIndex = Application.Match(CLng(Serials(n)), srg, 0) ' whole numbers
        If IsNumeric(sIndex) Then ' match found (a number)
            ' Combine each matching cell into a range.
            If sdrg Is Nothing Then ' first cell
                Set sdrg = srg.Cells(sIndex)
            Else ' all but the first cell
                Set sdrg = Union(sdrg, srg.Cells(sIndex))
            End If
        'Else ' no match found (an error value)
        End If
    Next n

    Dim dCount As long
          
    ' Copy and delete the range.
    If Not sdrg Is Nothing Then ' matches found
        
        dCount = sdrg.Cells.Count
        
        ' Create a reference to the destination first column range.
        Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
        Dim dfcell As Range: Set dfcell = dws.Cells(dws.Rows.Count, dlrCol) _
            .End(xlUp).Offset(1).EntireRow.Columns("A")
        Dim drg As Range: Set drg = dfcell.Resize(dCount)
        
        ' Copy and delete ('Cut' doesn't work with non-contiguous ranges).
        With sdrg.EntireRow
            .Copy drg
            .Delete
        End With
        
        ' Add timestamp.
        Dim TimeStamp As String: TimeStamp = Format(Now, TimeStampPattern)
        drg.EntireRow.Columns(dTimeStampCol).Value = TimeStamp
    
    'Else ' no matches found
    End If
          
    ' ???
    Dim fws As Worksheet: Set fws = wb.Worksheets(fName)
    fws.Activate
    fws.Range("A1").Select
          
    'wb.Save
          
    Application.ScreenUpdating = True
    
    Select Case dCount
    Case 0
        MsgBox "No records found.", vbCritical, ProcTitle
    Case 1
        MsgBox "Moved one record.", vbInformation, ProcTitle
    Case Else
        MsgBox "Moved " & dCount & " records.", vbInformation, ProcTitle
    End Select
  
End Sub

標籤：擅长 vba

上一篇：VBA測驗陣列中的值

下一篇：為什么我在使用ifs函式時在excel中出現值錯誤？