时间戳

首页 > 解决方案 > 查找值、剪切行并粘贴到单独的工作表中

excel - 查找值、剪切行并粘贴到单独的工作表中

问题描述

我想在工作表的某一列中找到具有特定值的人，剪切他们的行，然后将它们粘贴到指定的选项卡中。（如果我可以在其中一列的单元格中搜索特定单词会更好，因为涉及到我不想每年修复的财政年度。）

表 1
在此处输入图像描述

我正在寻找在 D 列中有“FD.Matching Gifts FY22”的人。或者只是匹配礼物的字样。我想剪切这些行并将它们粘贴到我的匹配选项卡中，然后删除空行。

我试过这个，我知道这不会得到我想要的一切，但这将是一个开始：

Sub CopyMatching()

Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range

Set StatusCol = Sheet1.Range("D2:D1000")
For Each Status In StatusCol

    If Sheet2.Range("A2") = "" Then
        Set PasteCell = Sheet2.Range("A2")
    Else
        Set PasteCell = Sheet2.Range("A1").End(x1Down).Offset(1, 0)
    End If
    
    If Status = "FD.Matching Gifts FY22" Then Status.Offset(0, -3).Resize(1, 24).Copy PasteCell

Next Status

End Sub

这里的错误是

“应用程序定义或对象定义错误”

然后我找到了这个，但我认为我没有把这些碎片放在正确的地方：

Sub MoveMatchRows()
  MoveRows "FD.MatchingGifts FY22"
End Sub

Sub MoveRows(Unit As String)
  With Sheets("Sheet1").Range("A1").CurrentRegion
    .AutoFilter  ' switch filtering on or clear previous filter
    .AutoFilter 4, appeal_desc  ' filter so that only rows with "NTS" or whichever unit is passed in, are visible
    If .Columns(4).SpecialCells(xlVisible).Count = 4 Then
      ' none found
      MsgBox "No " & appeal_desc & " rows found"
    Else
      ' With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
        ' now dealing with the data only, not the headings
        .Copy
        ' paste the data to the row after the last used row in new sheet for the unit
        Sheets(appeal_desc & " New").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlAll
        .EntireRow.Delete   ' remove the copied rows
      End
    End If
    .AutoFilter ' remove the filter
  End With
End Sub

这个错误是

“脚本超出范围”

标签： excelvba

解决方案

将标准行移动到另一个工作表

解决方案 ( AutoFilter)

  • 假设数据在一个表中（一行标题，不一定是一个Excel table），它是连续的（没有空行或列），并且它从 cell 开始A1。

  • 如果您只需要前 24 列，则可以执行以下操作之一：

    Set srg = Sheet1.Range("A1").CurrentRegion.Resize(, 24)
Set srg = Sheet1.Range("A1").CurrentRegion.Columns("A:X")

Option Explicit

Sub MoveMatchingDataRows()
    
    Const Title As String = "Move Data Rows"
    Const scCol As Long = 4
    Const dCol As Long = 1
    Const Criteria As String = "FD.Matching Gifts FY22"
    
    ' Remove any previous filters.
    If Sheet1.AutoFilterMode Then
        Sheet1.AutoFilterMode = False
    End If
    
    ' Filter.
    Dim srg As Range ' Source Range (Headers and Data)
    Set srg = Sheet1.Range("A1").CurrentRegion
    srg.AutoFilter scCol, Criteria
    
    ' Count the number of matches.
    Dim sdrg As Range ' Source Data Range (Without Headers)
    Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    Dim sdccrg As Range ' Source Data Criteria Column Range
    Set sdccrg = sdrg.Columns(scCol)
    Dim drCount As Long ' Destination Rows Count (Matches Count)
    drCount = Application.Subtotal(103, sdccrg)
    
    ' Move if there are matches.
    
    If drCount > 0 Then ' matches found
        
        Dim sdfrrg As Range ' Source Data Filtered Rows Range
        Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
        Dim dCell As Range ' Destination Cell
        Set dCell = Sheet2.Cells(Sheet2.Rows.Count, dCol).End(xlUp).Offset(1, 0)
        
        With sdfrrg
            
            .Copy dCell
            
            ' Either delete the entire worksheet rows...
            '.EntireColumn.Delete
            
            ' ... or remove filter to prevent...
            Sheet1.AutoFilterMode = False
            ' ... deleting the entire worksheet rows leaving possible data
            ' to the right (after the empty column) intact.
            .Delete xlShiftUp
        
        End With
    
    Else ' no matches
        
        Sheet1.AutoFilterMode = False
   
    End If
        
    ' Inform the user.
    Select Case drCount
    Case 0
        MsgBox "No matches found. No action taken.", vbExclamation, Title
    Case 1
        MsgBox "Found one match.", vbInformation, Title
    Case Else
        MsgBox "Found " & drCount & " matches.", vbInformation, Title
    End Select

End Sub

快速修复（循环）

  • 您不能以这种方式从上到下循环，因为如果有包含条件的连续行，则只会移动第一行以将第二行留在原处。您可以使用For...Next循环并相应地操作计数器变量，但它很慢并且感觉不对。
  • 以下解决方案中的问题是，由于我们是从下到上循环For r = CopyLastRow To CopyFirstRow Step -1（
  • 一个改进是使用Application.Unionie 从上到下循环，将每个匹配的单元格组合成一个范围，然后一次性复制和删除这个范围（每个操作）。我会写它，但有很多例子SO（例如Union，GetCombinedRange）。无论如何，AutoFilter提供最有效的方式。
Sub CopyMatching()

    Const CopyFirstRow As Long = 2

    Dim CopyLastRow As Long
    CopyLastRow = Sheet1.Range("D" & Sheet1.Rows.Count).End(xlUp).Row
    
    Dim PasteLastRow As Long
    PasteLastRow = Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row
    Dim PasteCell As Range
    Set PasteCell = Sheet2.Range("A" & PasteLastRow).Offset(1, 0)
    
    Application.ScreenUpdating = False
    
    Dim CopyCell As Range
    Dim r As Long
    
    For r = CopyLastRow To CopyFirstRow Step -1
        Set CopyCell = Sheet1.Range("D" & r)
        If CopyCell.Value = "FD.Matching Gifts FY22" Then
            With CopyCell.Offset(0, -3).Resize(1, 24)
                .Copy PasteCell
                .Delete
            End With
            Set PasteCell = PasteCell.Offset(1, 0)
        End If
    Next r

    Application.ScreenUpdating = True

End Sub

推荐阅读