Looping help for a newbie

[sschluet]

I have 3 dynamic lists with some blank rows that I'm trying to go through and get only the common results (and no blank rows) but I have no idea how to do that. The data looks like this:



[TABLE="class: outer_border, width: 500, align: center"]
<tbody>[TR]
[TD]List 1
[/TD]
[TD]List 2
[/TD]
[TD]List 3
[/TD]
[/TR]
[TR]
[TD]Revenue
[/TD]
[TD]Revenue
[/TD]
[TD]High value
[/TD]
[/TR]
[TR]
[TD]Device activation
[/TD]
[TD]Competitors
[/TD]
[TD]Roaming
[/TD]
[/TR]
[TR]
[TD]Customer quality
[/TD]
[TD][/TD]
[TD]Revenue
[/TD]
[/TR]
[TR]
[TD]Customer care
[/TD]
[TD]Device activation
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Device configuration
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Customer quality
[/TD]
[/TR]
</tbody>[/TABLE]

What I would like to pull from this example would be Revenue as it's the only common denominator here, but sometimes I get as many as 5 common answers back. Can someone help me please?

 

[JLGWhiz]

Hi sschluet, welcome to MrExcel forum and message board.

Assuming you want to list the results somewhere, and the lists appear in columns A:C, column D will be used.
If these parameters do not match your file, you will need to specify the details in your post.

Sub common()
Dim sh As Worksheet, lr As Long, rng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)
    For Each c In rng
        If Application.CountIf(Range("B:B"), c.Value) > 0 And _
        Application.CountIf(Range("C:C"), c.Value) > 0 Then
            sh.Cells(Rows.Count, 4).End(xlUp)(2) = c.Value
        End If
    Next
End Sub

 

[sschluet]

Thanks so much for the warm welcome and quick response! Unfortunately I'm getting Runtime error 13, Type Mismatch. The only thing I changed was the name of the sheet and that the range starts at A1 instead of A2 because I took the titles off the columns. Any idea why? I'm on Win7 with Excel 2007.

 

[sschluet]

And in looking up what causes this mismatch, I think my error handling on the list fields may be getting in the way. I'm doing some VLOOKUPs to create my lists like this:

=IFERROR(IF(VLOOKUP($B$5,Source!$N$3:$X$29,2,FALSE)=0,"",VLOOKUP($B$5,Source!$N$3:$X$29,2,FALSE)),"")

and to create the list I just change the column index number or the lookup value depending on the list and how it was constructed. So for each entry in the list, it's being done with this kind of string in the cell. I hope that gives better information.

 

[JLGWhiz]

Then let's try another approach. This shouldn't even consider the formula.

Sub common2()
Dim sh As Worksheet, lr As Long, rng As Range, Brng As Range, Crng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A1:A" & lr)
    For Each c In rng
        Set Brng = sh.Range("B:B").Find(c.Value, LookIn:=xlValues)
        Set Crng = sh.Range("C:C").Find(c.Value, LookIn:=xlValues)
        If Not Brng Is Nothing And Not Crng Is Nothing Then
            sh.Cells(Rows.Count, 4).End(xlUp)(2) = c.Value
        End If
        Set Brng = Nothing
        Set Crng = Nothing
    Next
End Sub

p.s. If you would have posted your modified code, I could have used the right sheet name. Also, it is helpful to know which line is highlighted for an error message.

 

[sschluet]

Ok, thanks for the tip. Unfortunately I'm still getting the error. Here's the modified code from the new set you gave me:

Sub common2()
Dim sh As Worksheet, lr As Long, rng As Range, Brng As Range, Crng As Range
Set sh = Sheets(Sheet6) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A1:A" & lr)
For Each c In rng
Set Brng = sh.Range("B:B").Find(c.Value, LookIn:=xlValues)
Set Crng = sh.Range("C:C").Find(c.Value, LookIn:=xlValues)
If Not Brng Is Nothing And Not Crng Is Nothing Then
sh.Cells(Rows.Count, 9).End(xlUp)(2) = c.Value
End If
Set Brng = Nothing
Set Crng = Nothing
Next
End Sub

I think the error is happening at the blue line, but it's not telling me exactly where the error is coming from, it just pops it up after stepping through the Sub and Set lines that come before it.

 

[ebfmaine]

Set sh = Sheets(Sheet6) 'Edit sheet name

try
Set sh = Sheets("Sheet6") 'Edit sheet name

 

[sschluet]

Aha! Now I see where my problem lies. After I changed the sheet name it works nicely, although the values populate in I2:I5 rather than in D column for some reason.

Next question is how to make it run when I want it to. What I would really like is for it to run automatically when C1 populates with something beside N/A, 0 or blank but so far my efforts have not worked. Here's the formula in CI since I'm getting this value by selecting menus and looking up values:

=IFERROR(IF(VLOOKUP(Searching_problem_AND_equip!$B$24,Source!$X$3:$AG$13,2,FALSE)=0,"",VLOOKUP(Searching_problem_AND_equip!$B$24,Source!$X$3:$AG$13,2,FALSE)),"")

Then here is the changed code that isn't working:

Sub common2()
Dim sh As Worksheet, lr As Long, rng As Range, Brng As Range, Crng As Range
Set sh = Sheets(6) 'Edit sheet name

If sh.Range("C1") Is Nothing Then
Range("I2:I5").ClearContents
Else

lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A1:A" & lr)
For Each c In rng
Set Brng = sh.Range("B:B").Find(c.Value, LookIn:=xlValues)
Set Crng = sh.Range("C:C").Find(c.Value, LookIn:=xlValues)
If Not Brng Is Nothing And Not Crng Is Nothing Then
sh.Cells(Rows.Count, 9).End(xlUp)(2) = c.Value
End If
Set Brng = Nothing
Set Crng = Nothing
Next

End If

End Sub


Can you tell me why this isn't working to run the script? It's not clearing the values nor is it running automatically. I'm sure something needs to happen here to make it run on change, but again this is a bit beyond me.

 

[ebfmaine]

Try this:

Private Sub Worksheet_SelectionChange(ByVal target As Range)

If target.Address = "$C$1" Then
'also added the end if

Dim sh As Worksheet, lr As Long, rng As Range, Brng As Range, Crng As Range
Set sh = Sheets(6) 'Edit sheet name

If sh.Range("C1") Is Nothing Then
Range("I2:I5").ClearContents
Else

lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A1:A" & lr)
For Each c In rng
Set Brng = sh.Range("B:B").Find(c.Value, LookIn:=xlValues)
Set Crng = sh.Range("C:C").Find(c.Value, LookIn:=xlValues)
If Not Brng Is Nothing And Not Crng Is Nothing Then
sh.Cells(Rows.Count, 9).End(xlUp)(2) = c.Value
End If
Set Brng = Nothing
Set Crng = Nothing
Next

End If

End if


End Sub


Can you tell me why this isn't working to run the script? It's not clearing the values nor is it running automatically. I'm sure something needs to happen here to make it run on change, but again this is a bit beyond me.[/QUOTE]

 

[sschluet]

Unfortunately this didn't work. Since I at least got my looping answer sorted out I'll post on the next 2 things I'm trying to achieve in a different thread to see if I can close them.