根据单元格是否包含数值/条件将行复制到另一个工作簿：isnumeric = true

Question

仍然是一个新手，在写这篇文章的过程中偶然发现了意外的成功，但仍然会发布它，以尝试了解更多有关自动过滤器以及条件引用如何在循环/其他条件事物中工作的信息。另外希望这篇文章可以帮助其他人。

我正在尝试编写一个 VBA 宏，该宏将根据要复制的行中的单元格 N(x) 是否包含数值，将行从工作簿 1 复制到工作簿 2。 基本上，我正在尝试创建一个数据库来跟踪我们是否收到了多余的样本，然后将其存储在内部。

在工作簿1中，如果收到的样品数的值高于发货的样品数，则余数将显示在“N”列中。如果不是，则返回“”。我想将第 N 列中返回值的任何行复制到 workbook2。

我发现了很多关于根据条件复制行的帖子，但当我修改它时，我似乎无法让任何代码工作。 下面是我尝试修改的两个不完整代码的示例。 （我在写这篇文章时不小心完成了第二个代码，但我不确定为什么它现在突然起作用了......）

Sub ESWcopypaste()

    Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
    Dim LR As Long, i As Long
    Dim R As Range

    Set AW = ThisWorkbook
    Set Awksht = AW.Worksheets("RECORDS")
    Set R = Awksht.Range([A2], Range("A" & Rows.Count).End(xlUp)) <-"Have tried a few variations here. I still have a problem where it reads a cell with a formula that returns "" as numeric and includes them in the count..."

    Workbooks.Open ("filepath to the ESW workbook")
    Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
    Set ESwksht = ESW.Worksheets(3)

    CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row <- "will be used to locate empty space to paste the contents, possible unnecessary when using autofilter"

    On Error Resume Next
        With R
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LR
            .AutoFilter , field:=1, Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                Sheets("ESwksht").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilter
        End With
    On Error GoTo 0

End Sub

上面的代码基于下面链接的帖子。我似乎无法弄清楚如何将过滤条件纳入此“Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)”的工作版本，这是不正确的，只是我敲击键盘试图让它工作...... https://www.mrexcel.com/board/threads/help-need-vba-code-to-copy-rows-to-a-new-worksheet-based-on-criteria.359760/

我的第一次尝试是使用条件复制和粘贴。它卡在粘贴行上，给我一个错误 13 类型不匹配消息。我变了

ESwksht.Range(R).Offset(1).PasteSpecial Paste:=xlPasteValues

到

ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

现在它可以工作了，不知道为什么...工作代码如下。

Sub CPESampleData()

    Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
    Dim LR As Long, i As Long
    Dim R As Range

    Set AW = ThisWorkbook
    Set Awksht = AW.Worksheets("RECORDS")
    Set R = Awksht.Range("A" & Rows.Count).End(xlUp)

    Workbooks.Open ("C:filepath to Extra Samples Catalog.xlsm")
    Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
    Set ESwksht = ESW.Worksheets(3)
    CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row

    AW.Activate

    With AW.Sheets("RECORDS")
        AW.Activate
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LR
            If IsNumeric(Range("N" & i).Value) = True Then
                Awksht.Rows(i).Copy
                ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            End If
        Next i
    End With

    ESwksht.Activate

End Sub

上面的代码是根据这两篇文章修改的。 https://www.mrexcel.com/board/threads/vba-conditional-copy-paste.468926/ VBA 将符合条件的行复制到另一张工作表

Answer 1

将筛选的行复制到另一个工作簿

复制列中带有数字的行（仅限值）

Sub CopyIfNumberRows()
    
    Application.ScreenUpdating = False

    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
    sws.AutoFilterMode = False
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    Dim Data As Variant: Data = sdrg.Value
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    Dim sr As Long, dr As Long, c As Long, WasDataCopied As Boolean
    
    For sr = 1 To UBound(Data, 1)
        If VarType(Data(sr, 14)) = vbDouble Then ' is a number
            dr = dr + 1
            For c = 1 To cCount
                Data(dr, c) = Data(sr, c)
            Next c
        End If
    Next sr
    
    If dr = 0 Then GoTo WriteMessage
    
    Dim dwb As Workbook:
    Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
    Dim dfcell As Range:
    Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim drg As Range: Set drg = dfcell.Resize(dr, cCount)
    
    drg.Value = Data

    'dwb.Close SaveChanges:=True

    WasDataCopied = True
    
WriteMessage:
    
    Application.ScreenUpdating = True
    
    If WasDataCopied Then
        MsgBox "If-number rows copied.", vbInformation
    Else
        MsgBox "No if-number rows found.", vbExclamation
    End If

End Sub

复制列中包含非 Nlank 单元格的行（值、格式和公式）

Sub CopyNonBlanksAutoFilter()
    
    Application.ScreenUpdating = False

    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
    sws.AutoFilterMode = False
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    Dim svrg As Range, WasDataCopied As Boolean
    
    strg.AutoFilter Field:=14, Criteria1:="<>"
    On Error Resume Next
        Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    If svrg Is Nothing Then GoTo WriteMessage
    
    Dim dwb As Workbook:
    Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
    Dim dfcell As Range:
    Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    svrg.Copy dfcell
    
    'dwb.Close SaveChanges:=True
    
    WasDataCopied = True
    
WriteMessage:
    
    Application.ScreenUpdating = True
    
    If WasDataCopied Then
        MsgBox "Non-blanks copied.", vbInformation
    Else
        MsgBox "No non-blanks found.", vbExclamation
    End If

End Sub