Extract list out of multiple sheets based on criteria - excel

Question

The problem that I'm facing is concerning Excel. I'm trying to extract rows with multiple columns out of sheets based on certain criteria. I've found some solutions regarding this, but nothing is really what I'm looking for or I can't change it to make it work. I'll try to explain the issue more detailed below using an example.
Situation:
8 sheets (named Sh1 to Sh8) with a list of tasks
Each sheet represents a kind of task (personal, work, ...)
Each sheet has the same format
Data is located starting from row 4 and between column A to K
Below the data is a row with total calculations
The data includes text, numbers and blank cells
Column D is the status of the task (C for completed, I for in progress, N for not started)
Style of the sheets is completely done by using conditional formatting
I would like something that checks those 8 sheets and copies all entries (including the blank cells) that are a certain status, being either C, I or N, to a new sheet, called "Filtering". The filtering sheet will have headers as well and the data should start at row 7.
When I started this, I came up with a formula (based on this) that copies all the entries of one sheet. I could filter it by putting C, I or N in the cell D4 on the filtering sheet.
{
=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)
)
);
"")
}
As I said before, the data includes blank cells, so I changed the formula to the following to make sure the blank cells didn't turn into 0's:
{
=IFERROR(
IF(
INDEX(SAME AS ABOVE)="";
"";
INDEX(SAME AS ABOVE);
);
"")
}
Although this worked, I could only perform this on one sheet, and not on all eight. I could solve this by starting Sh2 at a lower row in the filtering sheet and do this for all other sheets, but that's not really what I'd like to get. I would really like to get to a continuous list that sums up all the not started, completed or in progress by changing that one cell D4 on the filtering sheet.
That's where I would like your suggestions. If it's possible to do this without VBA, I'd prefer that, since I sometimes use it in the online web application and macro's don't work there. If VBA is the only solution, obviously that'd be okay too.
On a side note: I tried VBA based on a code that I found here. (please have patience with me, I never coded before this) but it seems really slow to process this. Every time I run the macro, it takes more than 15 seconds to calculate this, although there are only 200 tasks that I currently have. The following was for getting all the completed tasks. I could easily make the others by changing the C to I or N. There was another problem where the whole sheet was removed, including my headers, so I'd have to put a range on the clear.
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
Thanks already for reading through this and I'm looking forward to your suggestions.
Cheers,
Bart

Answer 1

The reason your code is taking too long to run is because you are looping through the entire column. You need to delimit the range to work with.
This solution:
• Allows the user to determine the extraction criteria using cell D4 in “Filtering” worksheet (Target)
• Sets the data ranges for each worksheet [Sh1, Sh2, Sh3, Sh4, Sh5, Sh6, Sh7, Sh8] (Source)
• Uses AutoFilter to select the data required and
• Posts the resulting ranges from all worksheets in the “Filtering” worksheet
It assumes that:
• All worksheets involved have the same structure and headers
• Headers are located at A6:K6 for Target worksheet and A3:K3 for Source worksheets (change as required)
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
Suggest to read the following pages to gain a deeper understanding of the resources used:
Range Object (Excel), Range.Offset Property (Excel),
Range.SpecialCells Method (Excel),
Select Case Statement, Worksheet.AutoFilter Property (Excel),
Worksheet.AutoFilterMode Property (Excel), With Statement