VBA 编码 - 循环从其他工作表复制可见（过滤）单元格答案

【问题标题】：VBA coding - loop Copy visible (filter) cell from Other SheetVBA 编码 - 循环从其他工作表复制可见（过滤）单元格
【发布时间】：2021-06-04 11:13:38
【问题描述】：

我是 VBA 新手，我的 VBA 代码被阻止。我正在尝试做的事情：在我的数据库中，在列 M:M 内，如果列 M:M 中的每个单元格包含“B1”，它会将工作表“数据库”中的行复制到另一个工作表（“工作”），在工作表（“分配”）上对单词“B1”进行过滤，并将过滤后的单元格从工作表（“分配”）复制到工作表（“工作”）

请找到我的代码：

    Dim r As Range
    Dim rw As Long, Cell As Range
    
    
    For Each Cell In Sheets("Database").Range("M:M")
    rw = Cell.Row
     If UCase(Cell.Value) Like UCase("*B1*") Then
      Cell.EntireRow.Copy
      
    Sheets("Work").Select
    Range("A1048576").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial xlPasteValues
    
Sheets("Alloc").Select
      Rows("1:1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$H$10000").AutoFilter Field:=1, Criteria1:= _
            "B1"

        Set r = Sheets("Alloc").Range("B2")
        Do While r.Value <> ""
          Range("N1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
        Loop

         Set r = Sheets("Alloc").Range("C2")
        Do While r.Value <> ""
          Range("O1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop

           Set r = Sheets("Alloc").Range("D2")
        Do While r.Value <> ""
          Range("P1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop
   
           Set r = Sheets("Alloc").Range("E2")
        Do While r.Value <> ""
          Range("Q1048576").End(xlUp).Offset(1, 0).Value = r.Value
            Set r = r.Offset(1)
      Loop
     
    Sheets("Alloc").Select
      Rows("1:1").Select
        Selection.AutoFilter
    
    
     End If
    
     Next

我的代码正在运行，唯一的问题是它的复制也是工作表（“alloc”）中的数据，这些数据也已归档你知道我如何只将工作表（“Alloc”）中的过滤数据放入工作表（“work”）吗？

非常感谢您的帮助

【问题讨论】：

你已经成功了一半。首先过滤您的数据，然后而不是循环，只需复制可见单元格并一次性粘贴它们。此处无需循环
以this solution 为例。您可以在此站点上找到许多示例。这只是搜索“过滤和复制可见单元格”后弹出的第一个
它正在工作 :) 非常感谢

标签： excel vba

【解决方案1】：

以下内容基于您对问题的描述，而不是您的代码。请尝试以下方法并让我知道它是如何进行的。假设Database 和Alloc 工作表在1 行中都有标题，从A1 和连续数据开始。

Option Explicit
Sub CopyData()

Dim ws1 As Worksheet: Set ws1 = Sheets("Database")
Dim ws2 As Worksheet: Set ws2 = Sheets("Alloc")
Dim ws3 As Worksheet: Set ws3 = Sheets("work")

Dim PasteRow As Long

PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1

With ws1.Cells(1, 1).CurrentRegion
    .AutoFilter 13, "*B1*", 7
    .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(PasteRow, 1)
    .AutoFilter
End With

PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1

With ws2.Cells(1, 1).CurrentRegion
    .AutoFilter 1, "B1", 7
    .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(PasteRow, 1)
    .AutoFilter
End With

End Sub

【讨论】：