View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.programming
INTP56 INTP56 is offline
external usenet poster
 
Posts: 66
Default Excel Challenge: Compare multiple worksheets macro

OK, since are looking for raw counts, not percentages, how about the following:

Name a worksheet "Options"
Cell Value or Formula
---- ------------------------------------------
A1 Option Number
B1 Option Description
C1 Search Range
D1 =CONCATENATE("Sheet",COLUMN()-3)
Copy D1 all the way to column IV

A2 to An Put in your option numbers
B2 to Bn Put in your option description
C2 to Cn Put in your search range
D2
=IF(OR(ISERROR(INDIRECT(CONCATENATE(D$1,"!",$C2))) ,ISBLANK($A2)),"",COUNTIF(INDIRECT(CONCATENATE(D$1 ,"!",$C2)),$A2))

NOTE: In my workbook, I assumed you would always be looking the same column,
so I entered C:C for each value in Column C.
Copy D2 down as far as you like, but at least as far down as the last option
number.

At this point, your Options sheet has the counts of each option for every
sheet, up to Sheet254. If at some time in the future, you decide to support
more options, simply add them to your list on this page, everything else will
adjust accordingly.

Put this code in one of your modules:

Public Sub CompareSheets()
Dim aws As Worksheet, ws As Worksheet
Dim rngActiveSheetName As Range, rngSheetName As Range
Dim lngLastOptionIdx As Long, sglNumMatches As Single, r As Long,
strMessageBox As String

Set aws = ActiveSheet
With ThisWorkbook.Worksheets("Options")
lngLastOptionIdx = .Cells(1, 1).End(xlDown).Row - 1
Set rngActiveSheetName = .Rows(1).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(1).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

Activate you worksheet of interest, then run the above procedure.

HTH, Bob