VBA宏将过滤后的数据复制并粘贴到新工作表答案

【问题标题】：VBA macro to copy and paste filtered data to new sheetVBA宏将过滤后的数据复制并粘贴到新工作表
【发布时间】：2020-07-21 07:23:31
【问题描述】：

我正在尝试将过滤后的数据从一个工作表复制到另一个工作表，但由于某种原因，我收到运行时错误 1004，提示“要将所有单元格从另一个工作表复制到此工作表，请确保将它们粘贴到第一个单元格（A1 或R1C1)" 我实际上不想复制标题行，所以该行的所有可见栏

我想要的是将复制的数据粘贴到目标工作表中的第一个可用行。这是我拥有的用于过滤某些内容的代码，但随后落在粘贴行上

Sub BBWin()
'
' BB Win Macro
' This macro will filter BB Win 1 - 8
'
    With ActiveSheet.Range("A1").CurrentRegion
      With .Resize(, .Columns.Count + 1)
         With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
            .FormulaR1C1 = "=if(or(rc7={""K.BB_Win_1_2019"",""K.BB_Win_2_2019"",""K.BB_Win_3_2019"",""K.BB_Win_4_2019"",""K.BB_Win_5_2019"",""K.BB_Win_6_2019"",""K.BB_Win_7_2019"",""K.BB_Win_8_2019""}),""X"","""")"
            .Value = .Value
         End With
         .HorizontalAlignment = xlCenter
      End With
        Cells.Select
        Selection.SpecialCells(xlCellTypeVisible).Copy
        Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
End Sub

有什么建议可以让它正常工作吗？

==========================================

好吧，也许我应该以另一种方式尝试这个问题，发布我提供的原始工作宏，而不是发布我重写它的尝试。

这与我在上面发布的内容基本相同，只是更改了公式以查找不同的文本，尽管它也具有自动筛选设置（我不需要）和隐藏列（我不需要）做）。这对我来说非常有效，并且完全符合它的预期。我基本上试图复制它并删除不需要的元素，但正如您所见，发现最初指出的错误。显然，我的知识有限导致了最初的问题。

Sub Low_Risk()
'
' Low Risk Lays Macro
' This macro will filter for Remove VDW Rank 1, Class, Distance <=1650, # of Runners <=9, Exclude Brighton, Yarmouth, Windsor & Wolverhampton
'
    With ActiveSheet.Range("A1").CurrentRegion
      With .Resize(, .Columns.Count + 1)
         With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
            .FormulaR1C1 = "=if(or(rc8={""Brighton"",""Yarmouth"",""Windsor"",""Wolverhampton""}),""X"","""")"
            .Value = .Value
         End With
         .AutoFilter Field:=4, Criteria1:="<=9"
         .AutoFilter Field:=11, Criteria1:="<=1650"
         .AutoFilter .Columns.Count, "<>X"
         .AutoFilter Field:=29, Criteria1:="<>1"
         .HorizontalAlignment = xlCenter
      End With
        .Columns("C:C").EntireColumn.Hidden = True
        .Columns("G:G").EntireColumn.Hidden = True
        .Columns("I:I").EntireColumn.Hidden = True
        .Columns("L:L").EntireColumn.Hidden = True
        .Columns("N:W").EntireColumn.Hidden = True
        .Columns("Y:AB").EntireColumn.Hidden = True
        .Columns("AD:AJ").EntireColumn.Hidden = True
        .Columns("AO:AO").EntireColumn.Hidden = True
        .Columns("AQ:BQ").EntireColumn.Hidden = True
        .Columns("BT:CP").EntireColumn.Hidden = True
        .Parent.AutoFilter.Range.Offset(1).Copy
        Workbooks("New Results File.xlsm").Sheets("Low Risk Lays").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
End Sub

如前所述，这绝对完美，嵌套 Withs 和所有。我可以更改原始公式，使其在正确的列中查找并且仅针对我想要的文本，但我显然无法成功删除自动过滤器元素和隐藏列的元素而不会出现错误。我认为删除 .Parent.AutoFilter.Range.Offset(1).Copy 行是罪魁祸首，但不确定如何删除不需要的元素。

这个原始宏是在一个论坛中提供给我的，我不愿意更改公式部分，它可以很好地查找需要复制的许多文本元素。这就是为什么我只希望更改自动过滤部分和隐藏列部分

我不确定这是否有帮助，但它可能会澄清一些事情

非常感谢您的努力

【问题讨论】：

标签： excel vba

【解决方案1】：

Cells.Select（没有前导句点将其绑定到With 块）将选择活动工作表上的所有单元格。

试试这个（嵌套的 With 让我有点困惑，所以删除了一对）

Sub BBWin()
    Dim arr, ws As Worksheet, lc As Long, lr As Long

    arr = Array("K.BB_Win_1_2019", "K.BB_Win_2_2019", "K.BB_Win_3_2019", _
                "K.BB_Win_4_2019", "K.BB_Win_5_2019", "K.BB_Win_6_2019", _
                "K.BB_Win_7_2019", "K.BB_Win_8_2019")

    Set ws = ActiveSheet
    'range from A1 to last column header and last row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=7, Criteria1:=arr, Operator:=xlFilterValues
        .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
    End With
      
    Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports") _
          .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False
End Sub

【讨论】：

你需要 rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy 给 op 没有标题的选择。
@SpyrosTzortzis - 谢谢我错过了那篇文章。
Cheers @Tim-Williams 不幸的是，这似乎要么没有过滤所需的文本，要么复制了所有内容，因为粘贴的是源表中的每个条目。
当我发布我的代码时，您的问题没有过滤，所以我认为它已经被过滤了。
添加了一些过滤

【解决方案2】：

Cells.Select 选择所有工作表单元格。

Selection.SpecialCells(xlCellTypeVisible) 保留所有单元格，因为没有任何内容是隐藏的，所有内容都是可见的。您说了一些关于“复制过滤数据”的内容，但您的代码没有过滤任何内容......

所以，没有地方可以粘贴所有单元格。

为了使您的代码正常工作，请将 Cells.Select 替换为 .Cells.Select（前面的点表示调整大小的 UsedRange）。即使不需要任何选择...

所以，（更好）使用.cells.SpecialCells(xlCellTypeVisible).Copy...

已编辑：

您的最后一个代码只需要复制过滤范围的可见单元格。所以，你的代码行

.Parent.AutoFilter.Range.Offset(1).Copy

必须替换为下一个：

.Parent.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Copy

或

.Offset(1).SpecialCells(xlCellTypeVisible).Copy

表示处理后的范围（`UsedRange'），从第二行开始。

【讨论】：

干杯 @FaneDuru 我的术语过滤数据可能不适合使用，但宏顶部的公式会查找 8 个特定的文本单元格，K.BB_Win_1_2019 等等。仅应复制和粘贴第 7 列中包含所需文本的行。
@honkin：这会稍微改变您的代码含义......但不会太大。 Range Parent 返回工作表对象。为了获得您需要的东西，确保只复制已处理的UsedRange 的可见单元格就足够了。它不是用于代码的地方。我将尝试编辑我的答案并放置一段能够解决您的问题的代码。至少，我是这么认为的……:)

【解决方案3】：

我想要的是将复制的数据粘贴到第一个目标工作表中的可用行。

您应该定义可用行来粘贴填充的行，或者定义要粘贴过滤数据的工作表中的第一个空白行。然后您就可以将数据粘贴到该行中。

在我的示例中，在我的示例中，我通过第 24 列中包含“P24128”的任何内容过滤我的数据工作表（源表）并粘贴到“Sheet8”（目标表）中。

我实际上不想复制标题行，所以所有可见的栏行

你也不想要标题。 :)

  Sub CopyFilteredDataSelection10()

  Dim ws As Worksheet
  Set ws = ThisWorkbook.Worksheets("Datawork")
  
  ws.Activate

 'Clear any existing filters
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

  '1. Apply Filter
   ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=24, Criteria1:="*P24128*" ' "*" & "P24128" & "*" ' im filtering by anything in col 24 that contains "P24128"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   ws.AutoFilter.Range.Copy 'copy the AF first
   
   Set Rng = ws.UsedRange.Offset(1, 0)
   Set Rng = Rng.Resize(Rng.Rows.Count - 1)
   
   Rng.Copy
    
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("Sheet8").Activate
  lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
  Range("A" & lr).Select
  ActiveSheet.Paste

  Application.DisplayAlerts = True
  
  '4. Clear Filter from original sheet
    On Error Resume Next
    ws.Activate
    ActiveSheet.ShowAllData
    On Error GoTo 0
   End Sub

不包括标题是什么

   ws.AutoFilter.Range.Copy 'copy the AutoFilter first
   Set Rng = ws.UsedRange.Offset(1, 0)
   Set Rng = Rng.Resize(Rng.Rows.Count - 1)
   Rng.Copy

&您的目标是在您激活目标工作表并找到其最后一行之后

lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1

【讨论】：