如果语句不起作用 - 如果该行中有特定值，则将各个行复制到不同的工作表

Posted 2023-03-27

【中文标题】如果语句不起作用 - 如果该行中有特定值，则将各个行复制到不同的工作表

【英文标题】：If statement not working - copying individual rows to a different sheet if there is a specific value in that row

【发布时间】：2022-01-17 16:38:19

【问题描述】：

我已经为此苦苦挣扎了一段时间： 我正在尝试编写一个脚本，通过单击按钮将整行从名为“搜索”的工作表复制到名为“订单”的工作表中。基于是否在 M 列的该行中输入了一个值。

我已经编写了 if 语句，以便它拉出值大于 0 的行。

但是 - 它总是只拉入“搜索”源数据库的顶行 - 从不包含有值的那些。

源中的数据都是公式 - 这可能是个问题吗？否则有没有办法将数据作为值复制和粘贴？

例如 - 在下图中，我想拉过 ID 1359399 和 1359403。但它总是拉过前两行（1359394 和 1359395）。

感谢您的帮助。

Sub CopySomeCells()
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim SourceRow As Long
Dim DestinationRow As Long

Set SourceSheet = ActiveWorkbook.Sheets("Search")
Set DestinationSheet = ActiveWorkbook.Sheets("Order")

DestinationRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, 2).End(xlUp).Row + 1
For SourceRow = 2 To SourceSheet.UsedRange.Rows.Count
    If SourceSheet.Range("M" & SourceRow).Value > 0 Then
        SourceSheet.Range(SourceSheet.Cells(SourceRow, 1), SourceSheet.Cells(SourceRow, 29)).Copy _
            DestinationSheet.Cells(DestinationRow, 2)
        DestinationRow = DestinationRow + 1
    End If
Next SourceRow
Range("M2:M7000").Clear

结束子

【问题讨论】：

行的检测有问题吗？还是使用复制/粘贴操作？在If 之后的行上放置一个断点，并在断点时检查值。由于您的顶行在相关列中似乎没有任何价值，我认为您的检测算法可能存在问题。

啊，是的！我刚刚这样做了 - 断点表明它是该点的正确数据。我认为这意味着它取决于被拉过的公式而不是值。您知道是否有一种方法可以仅将数据复制为值而不是完整的复制粘贴？

但是你说那些行根本没有被复制。您可以使用PasteSpecial 方法仅粘贴值，但我看不出这将如何阻止该行被复制。也许你有一个错误的参考。您没有显示任何On Error 声明吗？也许您应该将ActiveWorkbook 引用更改为ThisWorkbook

源工作表中数据的公式是逐行索引查询。所以它似乎正在识别正确的行，但是当它们被粘贴到目标时 - 它正在将行引用更改为第 1 行、第 2 行等，即使在源中它们是例如第11行，第14行。什么是特殊粘贴方法？

查看 VBA 帮助文件时该方法无法理解怎么办？

【参考方案1】：

使用自动筛选复制条件行

将满足列中条件的数据行复制到另一个工作表。

Option Explicit

Sub CopySomeRows()
    
    ' Source
    Const sName As String = "Search"
    Const sCol As Long = 13 ' M
    Const sCriteria As String = ">0" ' or "<>" for not blank, ' or "=" for blank
    ' Destination
    Const dName As String = "Order"
    Const dfCol As Long = 2 ' B
    ' Both
    Const cCount As Long = 29
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    
    Dim strg As Range ' Source Table Range (headers)
    Set strg = sws.Range("A1").CurrentRegion.Resize(, cCount)
    If strg.Rows.Count = 1 Then Exit Sub ' no data or just headers
    Dim sdrg As Range ' Source Data Range (no headers)
    Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    strg.AutoFilter sCol, sCriteria
    
    Dim sdvrg As Range ' Source Data Visible Range
    On Error Resume Next
        Set sdvrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    sws.AutoFilterMode = False
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dfCol).End(xlUp).Offset(1)
    
    If Not sdvrg Is Nothing Then
        sdvrg.Copy
        dfCell.PasteSpecial xlPasteValues
        dws.Activate
        dfCell.Select
        'Application.CutCopyMode = False ' the next line does the job
        sdrg.Columns(sCol).ClearContents ' or .Clear
        'sws.Activate
        MsgBox "Data copied.", vbInformation
    Else
        MsgBox "No data found.", vbExclamation
    End If
    
End Sub