查找空白单元格并移动行

Question

我正在尝试查找缺少街道地址并将他们的行移动到我工作表中的单独选项卡的人。

Sub NEW_NoAddress()

    Const Title As String = "Move Data Rows"
    Const scCol As Long = 6
    Const dCol As Long = 1
    Const Criteria As String = "ISEmpty()"
           
    ' 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 = Sheet10.Cells(Sheet10.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
        
End Sub

我尝试了“”、“ **”、“”“”，我想我尝试了一个具有 vbStringISNull、() 和其他我在 Google 中遇到的东西的东西。我考虑过另一个方向并保留 来移动那些有地址的人，但我宁愿将不正确的条目移动到我的例外选项卡中。

Answer 1

移动匹配行

• 很高兴你喜欢我的代码。不幸的是，它有一个很大的错误：

   drCount = Application.Subtotal(103, sdccrg)
  

  这类似于 Excel 的ACOUNT，在选择空白时会导致 0。

• 我已经在几个代码中看到了这一点，并认为它是有效的。是不是让我大吃一惊。

• 当您计划如此强烈地使用这样的代码时，您希望将不断变化的变量移动到参数部分以便轻松多次使用它（请参阅下面的长过程）。

• 您可以使用新程序...

  • ...你的第一个问题是这样的：

    Sub MoveMatchRows()
        MoveMatchingRows Sheet1, 4, "FD.Matching Gifts FY22", Sheet2, 1, False
    End Sub
    

  • ...昨天的问题是这样的：

    Sub NEW_Move_Stock_InKind_DAF()
        MoveMatchingRows Sheet1, 44, "<>*/*", Sheet8, 1, False
    End Sub
    

  • ...对于今天这样的问题：

    Sub NewNoAddress()
        MoveMatchingRows Sheet1, 6, "=", Sheet10, 1, False
    End Sub  
    

• 我已将 SourceCriteria 声明为变体并添加了 xlFilterValues 以便能够使用多个条件，例如Array("1", "2").

程序

Sub MoveMatchingRows( _
        ByVal SourceWorksheet As Worksheet, _
        ByVal SourceColumn As Long, _
        ByVal SourceCriteria As Variant, _
        ByVal DestinationWorksheet As Worksheet, _
        Optional ByVal DestinationColumn As Long = 1, _
        Optional ByVal DoClearPreviousDestinationData As Boolean = False)
    
    Const ProcTitle As String = "Move Matching Rows"
    
    ' Remove any previous filters.
    If SourceWorksheet.AutoFilterMode Then
        SourceWorksheet.AutoFilterMode = False
    End If
    
    ' Filter.
    Dim srg As Range ' Source Range (Headers and Data)
    Set srg = SourceWorksheet.Range("A1").CurrentRegion
    srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
    
    ' Create a reference to the Source Data Range (no headers).
    Dim sdrg As Range
    Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    ' Clear Destination worksheet.
    If DoClearPreviousDestinationData Then ' new data, copies headers
        DestinationWorksheet.Cells.Clear
    End If
    
    ' Attempt to create a reference to the Source Data Filtered Rows Range.
    Dim sdfrrg As Range
    On Error Resume Next
        Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not sdfrrg Is Nothing Then
        
        ' Create a reference to the Destination Cell (also, add headers).
        Dim dCell As Range ' Destination Cell
        Set dCell = DestinationWorksheet.Cells(1, DestinationColumn)
        If IsEmpty(dCell) Then
            srg.Rows(1).Copy dCell
            Set dCell = dCell.Offset(1)
        Else
            Set dCell = DestinationWorksheet.Cells( _
                DestinationWorksheet.Rows.Count, DestinationColumn) _
                .End(xlUp).Offset(1, 0)
        End If
        
        With sdfrrg
            .Copy dCell
            
            ' Either delete the entire worksheet rows...
            '.EntireColumn.Delete
            
            ' ... or remove filter to prevent...
            SourceWorksheet.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
        
        SourceWorksheet.AutoFilterMode = False
   
    End If
        
End Sub