有选择地复制和粘贴具有给定条件的行答案

【问题标题】：Selectively copy and paste rows with given criteria有选择地复制和粘贴具有给定条件的行
【发布时间】：2019-10-14 03:14:27
【问题描述】：

我正在尝试根据 J 列中出现的单词“是”来选择表中的行。

我有一个从 A 列到 J 列的表格，我想选择 J 列中有“是”的行，然后只将这些行粘贴到新工作表中。

选择后，我需要将这些行复制到新的工作表或 Word 文档中。

我尝试了一系列论坛，这是针对 Windows MS Excel 软件的，使用 VBA 宏。

我正在使用以下 VBA，但遇到问题：

Sub Macro1()
 Dim rngJ As Range
    Dim cell As Range

    Set rngJ = Range("J1", Range("J65536").End(xlUp))
    Set wsNew = ThisWorkbook.Worksheets.Add

    For Each cell In rngJ
        If cell.Value = "Yes" Then
            cell.EntireRow.Copy

            wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select

            ActiveSheet.Paste
        End If
    Next cell

End Sub

任何帮助将不胜感激！

【问题讨论】：

有问题 - 什么问题？如果这是您得到的错误消息，或者如果您的代码运行完成，则发布预期和实际结果。
wsNew 是一个工作表。当您执行 wsNew.Sheets("Sheet1")...? 时，您可能会遇到错误？我认为你只想做wsNew.Range("J66536").End(xlUp).Offset(1,0).Paste？
@BruceWayne - 同意，但我认为粘贴从 J 开始的整行也可能会导致错误？
注意：不要硬编码最后一个单元格。最近的 Excel 版本有超过 65536 行使用 Range("J" & Rows.Count) 代替。 • 您可能会从阅读How to avoid using Select in Excel VBA 中受益。
嗨@jsheeran，感谢您这么快回复我！我的错误消息是“运行时错误 438，对象不支持此属性或方法”。这发生在 wsNew.Sheets 行中

标签： excel vba

【解决方案1】：

使用类似的东西

Option Explicit

Public Sub CopyYesRowsToNewWorksheet()
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")

    Dim DataRangeJ As Variant 'read "yes" data into array for faster access
    DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value

    Dim wsNew As Worksheet
    Set wsNew = ThisWorkbook.Worksheets.Add

    Dim NextFreeRow As Long
    NextFreeRow = 1 'start pasting in this row in the new sheet

    If IsArray(DataRangeJ) Then        
        Dim iRow As Long
        For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
            If DataRangeJ(iRow, 1) = "yes" Then
                wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
                NextFreeRow = NextFreeRow + 1
            End If
        Next iRow
    ElseIf DataRangeJ = "yes" Then 'if only the first row has data
        wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
    End If
End Sub

线

wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value

只复制值而不进行格式化。如果您还想复制格式，请将其替换为

wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)

【讨论】：

嗨@PEH，非常感谢您的帮助和善意的解释！我在这条线上得到了一个不匹配错误@ For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array 有什么想法吗？
J 列中没有或只有一个“是”。请参阅我编辑的答案。
嗨@Pᴇʜ 感谢您的帮助。此代码设法创建一个新工作表，但没有任何内容被复制。我有一个从 A 列到 J 列的表，我想选择 J 列中有“是”的行，然后只将这些行粘贴到新工作表中...

【解决方案2】：

与其为每个单元格查找、复制和粘贴，为什么不全部查找，然后像这样复制并粘贴一次：

Sub Macro1()
Dim rngJ As Range
Dim MySel As Range

Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add

For Each cell In rngJ
    If cell.Value = "Yes" Then
        If MySel Is Nothing Then
            Set MySel = cell.EntireRow
        Else
            Set MySel = Union(MySel, cell.EntireRow)
        End If
    End If
Next cell

If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub

最好尽量避免使用Select；看到这个link。

【讨论】：