VBA loop through columns (find if value is in column, return column title to another cell, repeat for other columns)

[ns63]

Hi,

I have a dataset with several different columns - each column has a title (e.g. "C2") and each column has values in it. I am trying to write a VBA code so I can type in a value in B33, the code reads through the column to see if it's there and if it is, it copies in the column title below. I'd like to repeat this through all the columns so I have a list of the column titles which include the value I write in B33.

Any ideas? This is what I originally had, but needs tweaking with a loop and also I want all Column Names which get picked up to appear in a list. Thanks so much!!!

Sub Check()

'clear previous

Range("B35:B500").Clear



'Making insert text, answer is IF statement 1 or 0

Dim insert As String, answer As Integer

insert= Range("C2").Value



'Check if it's there

answer = WorksheetFunction.CountIf(Range("C:C"), Range("B33"))

' If statement and Then

If answer = 1 Then

Range("B35").Value = insert

End If



'repeating for others



insert = Range("D2").Value

answer = WorksheetFunction.CountIf(Range("D:D"), Range("B33"))

' If statement and Then

If answer = 1 Then

Range("B36").Value = insert

End If

......


End Sub

 

[shknbk2]

Download the module file from here and unzip and insert into your VBA project. You're looking for the 'modFindAll64.bas' file.

FindAll VBA Function

www.cpearson.com

Based on random data and making sure that "ancient" was in multiple columns, the results in the spreadsheet example came out of the code below.

Book1
	B	C	D	E	F	G
2		Header1	Header2	Header3	Header4	Header5
3		limping	profuse	snails	optimal	thinkable
4		desert	woozy	gabby	train	abiding
5		kneel	smile	ancient	ray	lazy
6		pop	strip	heady	ancient	rhetorical
7		observation	pocket	teaching	unlock	want
8		luxuriant	gold	black	wretched	crook
9		skip	freezing	ancient	roomy	grubby
10		heap	beautiful	ajar	male	incredible
11		private	steep	protect	rambunctious	tremendous
12		ancient	tacit	stuff	tawdry	lively
13		gorgeous	splendid	plate	uppity	ugly
14		snore	evanescent	rest	comparison	deadpan
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33	ancient
34
35	Header1
36	Header3
37	Header4
Sheet1

Option Explicit

Sub Check()
    Dim source As Range
    Dim target As Range
    Dim searchRange As Range
    Dim foundRange As Range
    Dim subCell As Range
    Dim header As String
   
    Range("B35:B500").Clear
   
    'Setup ranges
    Set source = Range("B33")
    Set target = Range("B35")
    Set searchRange = ActiveSheet.UsedRange
    If searchRange.Columns(1).Column < 3 Then
        Set searchRange = searchRange.Offset(0, searchRange.Columns(1).Column - 1)
    End If
   
    'Begin searching
    Set foundRange = FindAll(searchRange, source.Value, , , xlByColumns)
    If Not foundRange Is Nothing Then
        For Each subCell In foundRange
            header = Cells(2, subCell.Column).Value
            If target.Value = "" Then 'First entry found
                target.Value = header
            Else  'search all entries to see if already inserted (happens when count in any one column > 1
                If FindAll(Range("B:B"), header) Is Nothing Then
                    Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = header
                End If
            End If
        Next
    End If
End Sub