根据条件从多张表中提取列表

我面临的问题是关于Excel。 我试图根据特定的条件从表中提取多列的行。 我已经find了一些关于这个的解决scheme，但没有什么是我正在寻找的，或者我无法改变它使其工作。 我将尝试用一个例子来解释下面更详细的问题。

情况：

• 8张（名为Sh1至Sh8）与任务清单
• 每张表格代表一种任务（个人，工作，…）
• 每张纸都有相同的格式
• 数据位于第4行和列A到K之间
• 数据下面是一排总计算
• 数据包括文本，数字和空白单元格
• D列是任务的状态（C为已完成，I为正在进行，N为未开始）
• 工作表的风格完全通过使用条件格式

我想要检查这8张纸，并将所有的条目（包括空白单元格）都复制到名为“Filtering”的新表格中，这些条目是C，I或N。 过滤表也将有标题，数据应该从第7行开始。

当我开始这个时，我想出了一个公式（基于这个 ）复制一张表的所有条目。 我可以通过将C，I或N过滤到单元格D4中来过滤它。

{ =IFERROR( INDEX( Sh1!A$4:A$19;SMALL( IF( Sh1!$D$4:$D19=Filtering!$D$4; ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1 ); ROWS(Sh1!A$4:Sh1!A4) ) ); "") } 

如前所述，数据包含空白单元格，所以我将公式更改为以下内容以确保空白单元格不会变成0：

 { =IFERROR( IF( INDEX(SAME AS ABOVE)=""; ""; INDEX(SAME AS ABOVE); ); "") } 

虽然这有效，但我只能在一张纸上执行此操作，而不是全部执行此操作。 我可以通过在过滤表格的较低行开始Sh2来解决这个问题，并且对所有其他表单执行此操作，但这并不是我想要的。 我真的想得到一个连续的列表，总结所有未开始，已完成或正在进行的更改过滤表单上的一个单元格D4。

那就是我希望你的build议。 如果没有VBA就可以做到这一点，我宁愿这样做，因为我有时在networking应用程序中使用它，而macros在这里不起作用。 如果VBA是唯一的解决scheme，显然也可以。

在一个侧面说明：我尝试了基于我在这里find的代码的VBA。 （请耐心等待，我从来没有编码过），但是处理这个过程似乎很慢。 每次运行macros时，都需要15秒以上来计算，尽pipe目前我只有200个任务。 以下是要完成所有完成的任务。 我可以通过将C更改为I或N来轻松地创build其他人。还有一个问题是整个表格被删除，包括我的标题，所以我必须在清晰的范围内。

 Sub ExtractList() Dim ws As Worksheet Dim destinationWorksheet As Worksheet Dim columnD As Range Dim c As Range Dim count As Long Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering") destinationWorksheet.Cells.ClearContents count = 1 For Each ws In ActiveWorkbook.Worksheets If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name = "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or ws.Name = "Sh8" Then Set columnD = ws.Range("D:D") 'columnD For Each c In columnD If WorksheetFunction.IsText(c.Value) Then If InStr(c.Value, "C") > 0 Then c.EntireRow.Copy destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats count = count + 1 End If End If Next c End If Next ws End Sub 

感谢您阅读本文，我期待您的build议。

干杯，巴特

Answer 1

你的代码运行时间过长的原因是因为你正在遍历整个列。 您需要划分范围来处理。

此解决scheme：

•允许用户使用“筛选”工作表（目标）中的单元格D4确定提取标准

•设置每个工作表的数据范围[Sh1，Sh2，Sh3，Sh4，Sh5，Sh6，Sh7，Sh8]（Source）

•使用AutoFilterselect所需的数据和

•在“筛选”工作表中的所有工作表中张贴结果范围

它假设：

•涉及的所有工作表都具有相同的结构和标题

•标题位于目标工作表的A6:K6和源工作表的A3:K3 （根据需要更改）

 Sub ExtractList() Dim wshTrg As Worksheet, wshSrc As Worksheet Dim sCriteria As String Dim rDta As Range Dim rTmp As Range, rArea As Range, lRow As Long Rem Set Worksheet Target Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required With wshTrg Rem Sets Criteria from Cell [D4] in target worksheet sCriteria = .Cells(4, 4).Value2 .Cells(7, 1).Value = "X" 'To set range incase there is only headers .Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents End With Rem Process each worksheet lRow = 7 For Each wshSrc In ThisWorkbook.Worksheets Select Case wshSrc.Name Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8" With wshSrc Rem Clear AutoFilter If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter Rem Set Data Range Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11)) End With With rDta Rem Apply AutoFilter .AutoFilter Field:=4, Criteria1:=sCriteria Rem Set resulting range Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible) Rem Clear Autofilter .AutoFilter End With Rem Post Resulting range in target worksheet For Each rArea In rTmp.Areas With rArea wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2 lRow = lRow + .Rows.count End With: Next: End Select: Next End Sub 

build议阅读以下页面，以深入了解所使用的资源：

Range对象（Excel） ， Range.Offset属性（Excel） ， Range.SpecialCells方法（Excel） ，

selectCase语句 ， Worksheet.AutoFilter属性（Excel） ，

Worksheet.AutoFilterMode属性（Excel） ， 带语句