在 Excel 中將行從一個工作表復制並粘貼到另一個工作表

Question

我正在嘗試建立一個歸檔系統，當用戶從列下拉列表中選擇“是”並單擊“歸檔”按鈕時，所有已選擇要歸檔的條目都將移動到另一個工作表。 然而，我面臨的問題是每次存檔條目時，它只會覆蓋之前存檔的條目，因此存檔表上只有 1 行。 這是我目前正在使用的代碼

    Sub Archive_Yes()
    Dim MatchRow As Long, FirstRow As Long, LastRow As Long
    Dim Destination As Range

    Dim ws As Worksheet
    Dim i As Long
    Set ws = Sheets("Sales Order Log")

    FirstRow = 14
    LastRow = ws.Cells(ws.Rows.Count, "AA").End(xlUp).Row
    i = FirstRow
    
    Do While i <= LastRow
       If ws.Range("AA" & i).Value = "Yes" Then
           MatchRow = ws.Range("Z" & i).Row
 
           With Sheets("Archive")
             Set Destination = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
          End With

            ws.Range("A" & MatchRow & ":Z" & MatchRow).Copy Destination

            ws.Rows(MatchRow).Delete Shift = xlUp

            LastRow = LastRow - 1
        Else
   
          i = i + 1
        End If
    Loop
   
End Sub

任何指導將不勝感激。 謝謝

Answer 1

使用AutoFilter移動標准行

Sub Archive_Yes()
    
    Const sName As String = "Sales Order Log"
    Const sHeaderRowAddress As String = "A13:AA13"
    Const CriteriaColumn As Long = 27
    Const CriteriaString As String = "Yes"
    
    Const dName As String = "Archive"
    Const dFirstCellAddress As String = "A2"
    
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim srCount As Long
    Dim srg As Range
    With sws.Range(sHeaderRowAddress)
        Dim slRow As Long
        slRow = sws.Cells(sws.Rows.Count, CriteriaColumn).End(xlUp).Row
        srCount = slRow - .Row + 1
        If srCount < 2 Then Exit Sub ' no data or only headers
        Set srg = .Resize(srCount)
    End With
    Dim scCount As Long: scCount = srg.Columns.Count
    Dim sdrg As Range ' exclude headers and last column
    Set sdrg = srg.Resize(srCount - 1, scCount - 1).Offset(1)
          
    srg.AutoFilter CriteriaColumn, CriteriaString
          
    Dim svrg As Range
    On Error Resume Next
        Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    If svrg Is Nothing Then
        MsgBox "No filtered rows.", vbExclamation
        Exit Sub
    End If
        
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
    
    Dim dfCell As Range
    
    With dws.Range(dFirstCellAddress)
        
        Dim dlRow As Long
        dlRow = dws.Cells(dws.Rows.Count, .Column).End(xlUp).Row
        
        If dlRow < .Row Then
            Set dfCell = .Cells
        Else
            Set dfCell = dws.Cells(dlRow + 1, .Column)
        End If
    
    End With
    
    svrg.Copy dfCell
    svrg.EntireRow.Delete Shift:=xlShiftUp
     
    MsgBox "Data archived.", vbInformation
   
End Sub

Answer 2

請嘗試下一個改編的代碼：

Sub Archive_Yes()
    Dim FirstRow As Long, LastRow As Long, Destination As Range, rngDel As Range

    Dim ws As Worksheet, i As Long
    Set ws = Sheets("Sales Order Log")

    FirstRow = 14
    LastRow = ws.cells(ws.rows.count, "AA").End(xlUp).row
    
    For i = FirstRow To LastRow
       If ws.Range("AA" & i).value = "Yes" Then
            AddRange rngDel, ws.Range("A" & i & ":Z" & i)
        End If
    Next i
    Dim wsA As Worksheet, lastRowA As Long
    Set wsA = Sheets("Archive")
    lastRowA = wsA.Range("A" & wsA.rows.count).End(xlUp).row + 1

    If Not rngDel Is Nothing Then
         Debug.Print rngDel.Address, lastRowA: Stop
        Application.ScreenUpdating = False: Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
          rngDel.Copy wsA.Range("A" & lastRowA)
          rngDel.EntireRow.Delete
        Application.ScreenUpdating = True: Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
    End If
End Sub

Sub AddRange(rngU As Range, rngAdd As Range)
    If rngU Is Nothing Then
        Set rngU = rngAdd
    Else
        Set rngU = Application.Union(rngU, rngAdd)
    End If
End Sub

它應該非常快......請在測試后發送一些反饋。