Trying to filter data and display it on another sheet, however the data isn't fully copied - excel

Question

im trying to filter some data(sheet="Imported Data") and paste the data that matches to a sheet("Test"). However somehow it doesn't fully work. I have asked this kinda question before, but I've been trying for 3hours now but I can't get it done!
What I want:
- There are 3 single cells which the user can fill in which are the criteria(Collection , System and Tag)
- Collection is a MUST fill in for the user, the others can be left blank if the user wants it so. The result must be the entire row(Column A,B and C)
- If one, two or three criteria are filled in the chosen criterias must all match to copy to the new sheet (so if one criteria is left blank, the result should be all all three criteria. But the one not filled in can be any value).
- If all criteria match, from the sheet="Imported Data" also the value of column E must be copied to sheet("Test"),
this value of column E must be the cell which is in the same row as the matched values.
If you have any questions, fill free to ask... it's a bit hard to explain.
Thanks for the help in advance! This is what I have now:
Option Explicit
Sub FilterButton()
Dim SrcSheet As Worksheet, DestSheet As Worksheet
Dim SourceRange As Range
Dim aCell As Range, bCell As Range
Dim iLastRow As Long, zLastRow As Long
Dim Collection As String, System As String, Tag As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'~~> Set your sheet
Set DestSheet = Sheets("Test")
Set SrcSheet = Sheets("Imported Data")
'~~> Find Last Row in Col A in the source sheet
With SrcSheet
iLastRow = .Range("A" & .Rows.Count).End(xlDown).Row
End With
'~~> Find Last "Available Row for Output" in Col A in the destination sheet
With DestSheet
zLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
'~~> Set your ranges
Set SourceRange = SrcSheet.Range("A2:A" & iLastRow)
'~~> Search values
Collection = Trim(Range("lblImportCollection").Value)
System = Trim(Range("lblImportSystem").Value)
Tag = Trim(Range("lblImportTag").Value)
With SourceRange
'~~> Match 1st Criteria
Set aCell = .Find(What:=Collection, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Copy A:C. Then match for Crit B and Crit C and remove what is not required
DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _
SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value
'~~> Match 2nd Criteria
If Len(Trim(System)) = 0 Or _
aCell.Offset(, 1).Value <> System Then _
DestSheet.Range("B" & zLastRow).ClearContents
MsgBox System & " Not Found"
'~~> Match 3rd Criteria
If Len(Trim(Tag)) = 0 Or _
aCell.Offset(, 2).Value <> Tag Then _
DestSheet.Range("C" & zLastRow).ClearContents
MsgBox Tag & " Not Found"
If Not DestSheet.Range("B" & zLastRow).ClearContents Or _
DestSheet.Range("C" & zLastRow).ClearContents Then
'~~> Copy E:E. Then match for Crit B and Crit C and remove what is not required
DestSheet.Range("D" & zLastRow & ":" & "D" & zLastRow).Value = _
SrcSheet.Range("E" & aCell.Row & ":" & "E" & aCell.Row).Value
End If
'~~> Increase last row by 1 for output
zLastRow = zLastRow + 1
Do
Set aCell = .FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
'~~> Match 2nd Criteria
If Len(Trim(System)) = 0 Or _
aCell.Offset(, 1).Value <> System Then _
DestSheet.Range("B" & zLastRow).ClearContents
'~~> Match 3rd Criteria
If Len(Trim(Tag)) = 0 Or _
aCell.Offset(, 2).Value <> Tag Then _
DestSheet.Range("C" & zLastRow).ClearContents
'~~> Increase last row by 1 for output
zLastRow = zLastRow + 1
Else
Exit Do
End If
Loop
Else
MsgBox Collection & " not Found"
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Answer 1

I think it would be simpler to use the AdvancedFilter method, but your data setup is important.
I have assumed that your original data has Five columns (A:E), with headers being in Row 1
I have further assumed that the headers in columns A:C are "Collection", "System" and "Tag"
I have also assumed there is nothing of importance on "Test" (If there is, instead of "clearing" the entire worksheet, you can alter the code to only clear the relevant part, perhaps the first four columns.
Set up a criteria range (three columns, two rows) on your Imported Data sheet with the same headings in Row 1 as in columns A:C of your data source. You could use Data Validation to force an entry; or you could code something within the macro itself. Or you could develop a UserForm to populate these cells
After your user fills in the criteria, the macro should copy the relevant data. If all three items are populated, it will delete column D, otherwise, it will delete columns D:E.
If I've made some wrong assumptions about how your data is set up, you may need to delete more columns after doing the Filter.
Option Explicit
Sub FilterButton()
Dim SrcSheet As Worksheet, DestSheet As Worksheet
Dim SourceRange As Range
Dim CriteriaRange As Range
Dim DestRange As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'~~> Set your sheet
Set DestSheet = Sheets("Test")
Set SrcSheet = Sheets("Imported Data")
'~~> Set your ranges
Set SourceRange = SrcSheet.Range("a1").CurrentRegion
Set CriteriaRange = SrcSheet.Range("H1:J2") 'or wherever
Set DestRange = DestSheet.Range("A1")
'Activate Destination Sheet, Clear it, and run the filter
DestSheet.Activate 'Can only copy filtered data to active sheet
DestSheet.Cells.Clear
SourceRange.AdvancedFilter xlFilterCopy, CriteriaRange, DestRange
'Delete column D always, delete Column E if not three criteria
With DestRange.CurrentRegion
If WorksheetFunction.CountA(CriteriaRange.Rows(2)) <> 3 Then
Range(.Columns(4), .Columns(5)).Delete
Else
.Columns(4).Delete (xlToLeft)
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub