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

时间：2020-07-19 04:47:43

标签： excel vba

我正在尝试将过滤的数据从一个工作表复制到另一个工作表，但是由于某种原因，我收到运行时错误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行是罪魁祸首，但不确定如何删除不需要的元素。

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

我不确定这是否有帮助，但可能会澄清一些问题

欢呼，非常感谢您的努力

3 个答案:

答案 0 :(得分：2)

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

答案 1 :(得分：1)

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”）。

答案 2 :(得分：0)

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

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

在我的示例中，我通过第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
相关问题
最新问题