Enormous list of column headers and multiple criteria sort

[DSH]

I am looking to use a macro to go through a spreadsheet and find over 72 phrases (column headers) that are indicated positive in each row.

To use an example lets say we zoo names which are indicated by a column header. Continuing across the top row of headers are animal names. I want to find 72 specific animal names, even though there may be over 100 names, that are indicated positive. I am using the number one to indicate that an animal would be present at this zoo.

What I want the macro to do is create a new column header at the end of the existing column headers and indicate a positive using the number 1 if any of the 72 animals were present for that particular zoo on the row that the search is being done on and continue on down the list.

Is it possible to list 72 headers for a search and if so how would I go about creating a macro like this? Thanks

 

[mirabeau]

OK.

Now to check that I have it right, you can try running the following macro in a new workbook.

This macro just generates some test data which I think is more or less as you indicated.

On Sheet1 It has 12 places (zoo's?) listed in Column A and 6 animals listed in Row 1. In the body of the table are randomly scattered 1's and blanks.

In Sheet2, column A is a random selection of 3 animals from the list of 6.

If this looks like your setup, then you should be able to manually enter in another column headed "Present" some 1's where they are relevant.

If this is indeed your type of setup, I'll next post a (already written) macro that will enter what is present for as large a problem as you like, and should do so plenty fast enough for your purposes.

Sub testdata()
Sheets("sheet1").Activate
ActiveSheet.UsedRange.Clear
Dim rws&, cls&, td()
Dim i&, j&, s(), ns As Integer
cls = 6
rws = 12
ns = 3  'number of ans which are selected from the 10
ReDim td(1 To rws + 1, 1 To cls + 1), s(1 To cls + 1, 1 To 1)
For j = 2 To cls + 1: td(1, j) = "An_" & j - 1: Next j
For j = 2 To rws + 1: td(j, 1) = "Zoo_" & j - 1: Next j
For i = 2 To rws + 1: For j = 2 To cls + 1
    If Rnd > 0.6 Then td(i, j) = 1
Next j, i
Range("A1").Resize(rws + 1, cls + 1) = td
For j = 1 To cls
x = Int(Rnd * (cls + 1 - j)) + j + 1
s(j, 1) = td(1, x)
td(1, x) = td(1, j + 1)
Next j
With Sheets("sheet2")
    .Range("A:A").ClearContents
    .Range("A1").Resize(ns) = s
End With
End Sub

 

[DSH]

The only randomness in the sheet that will be present is the location of the header within the first row. It might be in column A one time and then in Column C another time. (I will be using the same macro in different sheets)

The match will be very specific to the header names ( in this example: tigers, elephants and giraffes).

As a side note the cells without 1's in them will probably have zeros

 

[mirabeau]

1. Put your example data from post #1 on Sheet1 of a new workbook. But leave out your column headed "Present".

2. In Sheet2, type or copy tigers, elephants and giraffes (capitalized if need be to match those on Sheet1) separately in cells A1, A2 and A3.

3. Run the following code. It should give you the same column headed "Present" as you have on Sheet1.

4. This code is easily generalized to allow for as many locations and as many animals as you like.

Sub Present()
Dim d As Object, c As Range, e
Dim rws&, cls&, a, q(), i&, j&
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet2")
    Set c = .Range("A1")
    For Each e In .Range(c, c(Rows.Count).End(3)).Value
        d(e) = 1
    Next e
End With
Sheets("sheet1").Activate
rws = 9: cls = 7
a = Range("A1").Resize(rws, cls)
ReDim q(1 To rws, 1 To 1)
For i = 2 To rws
    For j = 2 To cls
    If (a(i, j) = 1) * (d(a(1, j)) = 1) Then q(i, 1) = 1: Exit For
    Next j
Next i
With Cells(1, cls + 1)
    .Resize(rws) = q
    .Value = "Present"
    .Resize(rws).Font.Color = vbRed
End With
End Sub

 

[DSH]

It is a beautiful thing. Works well. Your patience and assistance is very much appreciated.

 

[DSH]

This works well my question is since the rows and columns will vary from sheet to sheet what vba lines can we put in to find the last row and the last column placing the new header after the current last column

 

[mirabeau]

This works well my question is since the rows and columns will vary from sheet to sheet what vba lines can we put in to find the last row and the last column placing the new header after the current last column

How about this?

Sub Present2()
Dim d As Object, c As Range, e
Dim rws&, cls&, a, q(), i&, j&
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet2")
    Set c = .Range("A1")
    For Each e In .Range(c, c(Rows.Count).End(3)).Value
        d(e) = 1
    Next e
End With
Sheets("sheet1").Activate
'rws = 9: cls = 7  'This row now inactive, replaced by the following:
rws = Cells.Find("*", after:=[a1], searchorder:=xlByRows, _
        searchdirection:=xlPrevious).Row
cls = Cells.Find("*", after:=[a1], searchorder:=xlByColumns, _
        searchdirection:=xlPrevious).Column
a = Range("A1").Resize(rws, cls)
ReDim q(1 To rws, 1 To 1)
For i = 2 To rws
    For j = 2 To cls
    If (a(i, j) = 1) * (d(a(1, j)) = 1) Then q(i, 1) = 1: Exit For
    Next j
Next i
With Cells(1, cls + 1)
    .Resize(rws) = q
    .Value = "Present"
    .Resize(rws).Font.Color = vbRed
End With
End Sub

 

[DSH]

Works flawlessly. Excellent macro. Thank you again.