VB Code only writing one row to Results tab.

[Galland]

Desired results is to read from the criteria tab

Find the corresponding match in the Data tab

And write the results in the Dest Tab

My problem is my VB script is only writing one value and not all of them.

Dim rng As Range, cell As Range
Application.ScreenUpdating = False
Set wsData = Sheets("Data")
Set wsCriteria = Sheets("Criteria")
Set wsDest = Sheets("Dest")


lr = wsCriteria.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsCriteria.Range("A2:A" & lr)

If wsData.FilterMode Then wsData.ShowAllData


For Each cell In rng
With wsData.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=cell.Value

wsData.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")
wsDest.UsedRange.Columns.AutoFit
End With

Next cell
wsData.AutoFilterMode = False
wsData.Activate
Application.ScreenUpdating = True
End Sub

Data Tab

name	age	city	state	zip	cell	desk
Bob	20​	Jackson	NY	12345​	123​	234​
ZZZXCarol	21​	Hazard	KY	12346​	123​	234​
Danielle	22​	London	TN	12347​	123​	234​
Steve	23​	Pineville	Mi	12348​	123​	234​
123Jen456	24​	Somerset	WY	12349​	123​	234​
Naresh	25​	Manchester	PA	12350​	123​	234​
Ron	26​	Monticello	VA	12351​	123​	234​
Sam XXX	27​	Albany	UT	12352​	123​	234​
Vinny	28​	Morehead	AL	12353​	123​	234​

Criteria TAB

name

Bob

Carol

Danielle

Steve

Jen

Naresh

Ron

Sam

Vinny

Dest TAB

name	age	city	state	zip	cell	desk
Vinny	28​	Morehead	AL	12353​	123​	234​

 

[JoeMo]

When finished, the Dest tab contains the name 123Jen456 from the Data tab since it matched Jen in the Criteria tab.
Is it possible to return the Jen from the Criteria tab when it finds the match of 123Jen456in the Data tab?
If not its no big deal since I will have all my matching rows.

You are welcome - thanks for the reply.
As for your latest "one more thing", I'd like to start with the exact code you are using now to make modifications. Please post the full code you are currently using and I'll take a shot at modifying same to incorporate this latest request.

 

[Galland]

Thanks Joe!

Option Explicit
Sub FilterAndCopyData()
Dim wsData As Worksheet, wsCriteria As Worksheet, wsDest As Worksheet
Dim lr As Long
Dim rng As Range, cell As Range
Dim nxtcell As Long


Application.ScreenUpdating = False
Set wsData = Sheets("Data")
Set wsCriteria = Sheets("Criteria")
Set wsDest = Sheets("Dest")


lr = wsCriteria.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsCriteria.Range("A1:A" & lr)

If wsData.FilterMode Then wsData.ShowAllData


For Each cell In rng
With wsData.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:="*" & cell.Value & "*" ' remember the field:=1 is the search field

nxtcell = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1

wsData.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & nxtcell)
wsDest.UsedRange.Columns.AutoFit


End With

Next cell

wsData.AutoFilterMode = False
wsData.Activate
Application.ScreenUpdating = True

End Sub

 

[JoeMo]

OK, here's a lightly tested modification to do what you have requested. Note that if you have Names like Robert and Rob in your data sheet you will get a duplicated output of the record for Robert in the destination sheet because when filtering for Rob the output will also include Robert via the wildcards used in the filter criteria. I have removed duplicate records from the Dest sheet to handle this, but there are likely to be other gotchas of this type. Also note that I've assumed that the Name column on the Data sheet is populated with constants - no formulas in that column.

Option Explicit
Sub FilterAndCopyData()
Dim wsData As Worksheet, wsCriteria As Worksheet, wsDest As Worksheet
Dim lr As Long
Dim rng As Range, Rdata As Range, cell As Range, V As Variant
Dim nxtcell As Long, x, cd As Range
Application.ScreenUpdating = False
Set wsData = Sheets("Data")
Set Rdata = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row)
V = Rdata.Value
Set wsCriteria = Sheets("Criteria")
Set wsDest = Sheets("Dest")
lr = wsCriteria.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsCriteria.Range("A2:A" & lr) 'assumes there's a header on Criteria col A
If wsData.FilterMode Then wsData.ShowAllData
For Each cell In rng
    With wsData.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:="*" & cell.Value & "*" ' remember the field:=1 is the search field
        For Each cd In .Offset(1, 0).SpecialCells(xlCellTypeVisible).Columns(1)
            x = Application.Match(cd.Value, rng, 0)
            If IsError(x) Then
                If InStr(1, cd.Value, cell.Value) > 0 Then cd.Value = cell.Value
            End If
        Next cd
        nxtcell = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wsData.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & nxtcell)
        wsDest.UsedRange.Columns.AutoFit
    End With
Next cell
Rdata.Value = V
wsDest.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
wsData.AutoFilterMode = False
wsData.Activate
Application.ScreenUpdating = True
End Sub

 

[Galland]

Wow Joe this worked perfectly!
I never would have figured that out.

Thanks great job!!

 

[JoeMo]

Wow Joe this worked perfectly!
I never would have figured that out.

Thanks great job!!

You are welcome - thanks for the reply ...... and if you think I provided a solution, perhaps you can mark post #13 to show this.