FireVic,
Except for linebreaks, I copied the runable code right from an Excel 2003
workbook code module. I'll include a copy of a new sub that shouldn't
linebreak.
The search column just allows you to look for different options in different
columns. In my example, I assumed you would be looking in the same column
each time, and I just made things easier for myself by putting in exactly
what my formula was looking for. That's just one of my quirks to separate
things like that out, you could leave that column out and just hard code the
text in the formulas. However, suppose instead of having a single column with
a number in it, you needed to look for certion options in different columns.
e.g. Options 1-4 show up in column 3 as before, but option 5 shows up in
column 10. For sake of argument, let's say it's value is also 1.
In that case,
Cell Value or Formula
---- --------------------
A6 1
B6 E
C6 J:J
D6 and beyond unchanged
The Worksheet would now count the number of times the values 1-4 show up in
column 3, and the number of times the value 1 shows up in column 10, and give
you the % match accordingly.
The sheet as I have it, supports 65,535 option choices, do you have more
than that? There should only be one Options worksheet in your workbook, all
the others would be your sheets, (e.g. Sheet1, Sheet2, Sheet3, etc). As you
add new worksheets to the workbook, the options sheet updates itself
automatically.
Actually, if you are willing to live with 65,534 option chioces, you could
do the whole thing without using VBA at all. Although the solution I have in
mind would use array formulas, and would be relatively slow.
NOTE: This doesn't apply in this case, but sometimes I have the requirement
that my solutions work in High Security Mode (i.e. No macros) so I've had to
get creative with getting worksheets to do things that are easier and faster
to do with a macro.
Take the Options sheet, and make a copy of it using Edit/Move or Copy Sheet,
and rename it Options2. Then insert one line at row 1, so that Option Number
is now in A2, enter the following
A1 =COUNTA($A3:$A65536)
B1 Sheet3
C1 =MATCH(B1,2:2,0)
D1
=SUM(IF(ISNUMBER($A3:$A65536),IF(D3
65536=INDIRECT(CONCATENATE("R3C",$C$1,":R65536C",$C$1),FALSE),1,0),0))/$A$1
This is an array formula, so after pasting it in, press Ctrl - Shift -
Enter. If you did it correctly, you will see your formula bracketed with {}
E1+ Copy D1 across to Column IV
NOTE: When I say copy across, I mean click in the cell D1, then grab the
little square in the lower right hand corner and drag it all the way to
column IV.
Now if you type in the reference sheet in B1 (e.g. Sheet1, Sheet2, etc) the
percent match against it will be shown above every sheet name. As a check,
you should see 100% as the match. This does not require any VBA to
accomplish the same task.
Here is another version of the code, meant to use Options2, hopefully
without line breaks.
Bob
Public Sub CompareSheets2()
Dim aws As Worksheet, ws As Worksheet
Dim rngActiveSheetName As Range, rngSheetName As Range
Dim lngLastOptionIdx As Long, sglNumMatches As Single
Dim r As Long, strMessageBox As String
Dim rngHeaderCell As Range, lngHeaderRow As Long
Set aws = ActiveSheet
With ThisWorkbook.Worksheets("Options2")
Set rngHeaderCell = .Columns(1).Find(What:="Option Number" _
, LookIn:=xlValues, LookAt:=xlWhole)
If rngHeaderCell Is Nothing Then Exit Sub
lngHeaderRow = rngHeaderCell.Row
lngLastOptionIdx = _
.Cells(lngHeaderRow, 1).End(xlDown).Row - lngHeaderRow
Set rngActiveSheetName = _
.Rows(lngHeaderRow).Find( _
What:=aws.Name, LookIn:=xlValues, LookAt:=xlWhole)
If rngActiveSheetName Is Nothing Then Exit Sub
strMessageBox = "SheetName" & vbTab & "% Match"
For Each ws In aws.Parent.Worksheets
If ws.Name <> aws.Name Then
Set rngSheetName = _
.Rows(lngHeaderRow).Find( _
What:=ws.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngSheetName Is Nothing Then
sglNumMatches = 0
For r = 1 To lngLastOptionIdx
If rngSheetName.Offset(r, 0).Value = _
rngActiveSheetName.Offset(r, 0).Value Then
sglNumMatches = sglNumMatches + 1
End If
Next r
strMessageBox = strMessageBox & vbCrLf & _
rngSheetName.Value & vbTab & _
Format(sglNumMatches / lngLastOptionIdx, "0.00%")
End If
End If
Next ws
.Activate
Range(rngActiveSheetName, _
rngActiveSheetName.Offset(lngLastOptionIdx, 0)).Select
End With
MsgBox strMessageBox
aws.Activate
End Sub
