Copy highlighted cell and sheet name to destination worksheet - vba

Question

I am trying to copy cell values that meet two conditions: (1) highlighted row, and (2) have a particular region code, e.g. "WA". Need to copy cell values from column B to the destination worksheet below the header in column A. In addition, copy the sheet name that corresponds to those values that meet those conditions to column C to the destination worksheet.
Problems I have encountered:
As soon as I add this code it runs but doesn't past any values to the destination sheet. LCase(Cells(Cell.Row, "A").Value) = "wa"
If I remove the line of code above, and change the target area to look in column 2 Set Target = .Range(.Cells(1, 2), .Cells(LastRow, 2)), it will list the values that are highlighted in column B and paste them down starting on A1, instead of starting below the header.
Partial Target Area (full target area has different region codes and values going down these columns):
Sub Criteria()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wkb As Workbook
Dim Sh As Worksheet
Dim DestSh As Worksheet
Dim LastRow As Long, LastCol As Long, Last As Long
Dim Target As Range, Cell As Range, Dest As Range
Dim DestCounter As Long
' Delete the data off of AdvFilter sheet.
ActiveWorkbook.Worksheets("AdvFilter").Range("A5:F5" & Last + 1).Cells.Clear
On Error GoTo 0
'initialize destination counter
DestCounter = 1
Set DestSh = ThisWorkbook.Worksheets("AdvFilter")
For Each Sh In ThisWorkbook.Worksheets
If ActiveSheet.Visible = True Then
Last = fLastRow(DestSh)
With Sh
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Target = .Range(.Cells(1, 1), .Cells(LastRow, 2))
End With
For Each Cell In Target '<~ loop through each cell in the target space
If AmIYellow(Cell) And Cell.Value <> "" And _
LCase(Cells(Cell.Row, "A").Value) = "wa" Then
Set Dest = DestSh.Cells(Last + DestCounter, 1)
Cell.Copy Dest
DestCounter = DestCounter + 1
End If
Next Cell
End If
Next Sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function fLastRow(Sh As Worksheet)
On Error Resume Next
LastRow = Sh.Cells.Find(What:="*", _
After:=Sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Answer 1

If you only need the data and not the formatting; you'll be better off using an array to collect the data and write all the data in one operation to the target range.
Sub Criteria()
Dim ws As Worksheet
Dim r As Range
Dim x As Long
Dim Data
ReDim Data(1 To 2, 1 To 1)
With ActiveWorkbook.Worksheets("AdvFilter")
.Range(.Range("A" & .Rows.Count).End(xlUp), "F5").Cells.Clear
End With
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
With ws
For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If LCase(r.Value) = "wa" And r.Interior.ColorIndex = 6 Then
x = x + 1
ReDim Preserve Data(1 To 2, 1 To x)
Data(1, x) = r.Offset(0, 1)
Data(2, x) = ws.Name
End If
Next
End With
End If
Next
With ActiveWorkbook.Worksheets("AdvFilter")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
If x > 0 Then .Resize(x, 2).Value = Application.Transpose(Data)
End With
End With
End Sub