Excel VBA脚本，用于根据条件将多个选项卡中的行合并为一个

Question

我有一个包含多个工作表的Excel工作簿，这些工作表的结构都相同。我想整合所有数据，在第238列中，它对摘要工作表说“是”。理想情况下，它只会复制某些列而不是满足此条件的完整行。

我有这个代码作为基础：

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

' Loop through all worksheets and copy the data to the 
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        ' Find the last row with data on the summary worksheet.
        Last = LastRow(DestSh)

        ' Specify the range to place the data.
        Set CopyRng = sh.Range("A1:G1")

        ' Test to see whether there are enough rows in the summary
        ' worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        ' This statement copies values and formats from each 
        ' worksheet.
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With

        ' Optional: This statement will copy the sheet 
        ' name in the H column.
        DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub 

这是复制整个工作表。我想实现只从每个工作表中复制符合条件的某些行。

编辑：为了更清楚，上面的代码是我找到的一些代码。我想用一个循环或过滤器替换它复制指定范围的部分，该循环或过滤器只复制符合条件的每个工作表中的行（在这种情况下是一个具有值“是”和“否”的列，我只想要复制表示“是”的行并将其粘贴到合并表中（RDBMergeSheet）

谢谢您的帮助！

Answer 1

您的问题：我有一个包含多张表格的Excel工作簿，这些工作表的结构相同。我想整合所有数据，在第238列中，它对摘要工作表说“是”。

Ans：删除没有yes单元格的行似乎更容易。那是在编译完所有表格之后。因此，假设您已编译摘要表中每个工作表的所有行和列。

Sub Delete_all_non_yes()
  Sheets("Summary").Select
  Dim checked_cell As Integer
  Dim NB_rows As Integer
  ActiveCell.SpecialCells(xlLastCell).Select
  NB_rows = ActiveCell.Row
  Dim Checked_cell_value As String
  checked_cell = 1
  Do While checked_cell <= NB_rows
    Checked_cell_value = Cells(checked_cell, 278)
    If Not Checked_cell_value = "Yes" Then 
      'checks each row for the value "Yes"
       Rows(checked_cell).Delete
    Else
      checked_cell = checked_cell + 1
    End If

  Loop

End Sub

然后，您可以使用相同的逻辑并删除您要查找的任何列。有很多更有效的方法，但这应该完成工作。

注意：我的第一个stackoverflow Ans！欢迎反馈。