从包含单词的单元格的每个工作表中复制行

Question

我正在构建一个工作簿，其中每个工作表都用于软件安装的不同阶段。我试图通过将失败行复制到摘要表中来汇总 失败 的步骤。我终于让他们拉了，但他们拉到了同一行的新工作表中，因为它们位于原始工作表中。

这是我现在使用的：

Option Explicit

Sub Test()

Dim Cell As Range

With Sheets(7)
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
        If Cell.Value = "Fail" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next Cell
End With

End Sub

我需要：

1. 拉取单元格包含“失败”的行
2. 从第 4 行开始将行复制到主目录并连续向下而不覆盖
3. 一次遍历所有工作表- *（它们在安装的每个步骤中都被命名 - 我需要重命名为“sheet1、sheet2 等”？？？？）
4. 运行宏时清除以前的结果（以避免重复）

另一位用户向我提供了一个自动过滤宏，但它在这一行的 1004 上失败了 ".AutoFilter 4, "Fail""

Sub Filterfail()

Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")

Application.ScreenUpdating = False
        
        'sh.UsedRange.Offset(1).Clear  'If required, this line will clear the Master sheet with each transfer of data.
        
        For Each ws In Worksheets
                If ws.Name <> "Master" Then
                        With ws.[A1].CurrentRegion
                                .AutoFilter 4, "Fail"
                                .Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
                                .AutoFilter
                        End With
                End If
        Next ws

Application.ScreenUpdating = True

End Sub

Answer 1

试试这个：

此xRStr = "Completed" 脚本中的文本“Completed” 表示您要复制行的具体条件；

这个Set xRg = xWs.Range("C:C")脚本中的C:C表示条件所在的具体列。

Public Sub CopyRows()

Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer

On Error Resume Next

Application.DisplayAlerts = False

xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
    xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1

For Each xWs In ActiveWorkbook.Worksheets
    If xWs.Name <> xStr Then

        Set xRg = xWs.Range("C:C")
        Set xRg = Intersect(xRg, xWs.UsedRange)

        For Each xRRg In xRg
            If xRRg.Value = xRStr Then
               xRRg.EntireRow.Copy
               xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
               xC = xC + 1
            End If

        Next xRRg
    End If
Next xWs

Application.DisplayAlerts = True

End Sub

Answer 2

这是另一种方式 - 您必须分配自己的表格 - 我使用 1 和 2 而不是 2 和 7

Sub Test()
   Dim xRow As Range, xCel As Range, dPtr As Long
   Dim sSht As Worksheet, dSht As Worksheet
   
   ' Assign Source & Destination Sheets - Change to suit yourself
     Set sSht = Sheets(2)
     Set dSht = Sheets(1)
   ' Done
   
   dPtr = Sheets(1).Rows.Count
   dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
   
   For Each xRow In sSht.UsedRange.Rows
      Set xCel = xRow.Cells(1, 1)                 ' xCel is First Column in Used Range (May not be D)
      Set xCel = xCel.Offset(0, 4 - xCel.Column)  ' Ensures xCel is in Column D
      If xCel.Value = "Fail" Then
         dPtr = dPtr + 1
         sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
      End If
   Next xRow
End Sub

我认为您自己代码中的一个问题与这一行有关

    .Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Rows.Count 部分，“A”应该是指目标工作表（2），但不是因为行

With Sheets(7)

进一步