Excel Challenge: Compare multiple worksheets macro

F

FireVic

Thanks in advanced for time:

I am going to be adding a list of option numbers with their description per
order to worksheets. The worksheets will be named sequentialy as Sheet1
Sheet2 etc.

The option number will be in column A and option description (useless so
far) will be in column b

Every time I add a worksheet, I want to be able to compare this worksheet
with all of the worksheets stored comparing common and uncommon option
between them.


When the comparison macro stops running comparing all of the available
worksheets, I should be able to see a percentage of matches (same value
options) per worksheet that exist in a message box. Like:

Sheet1 90% Match
Sheet2 95% Match
Etc.

Thanks again!
 
D

Derek Johansen

Does each worksheet have the same number of entries, or are they going to
have different amounts of information?
 
I

INTP56

I'm not exactly sure what you are looking for.

Consider the following, where Sheet1# is the number of times the option
shows up on Sheet1, Sheet2# is the number of times that option shows up on
Sheet2, etc.

Option # Desc Sheet1# Sheet2# Sheet3#
1 A 50 10 0
2 B 30 10 5
3 C 10 10 10
4 D 40 10 15
5 E 20 10 20

What % match would you assign to Sheet3 relative to Sheet1?
What % match would you assign to Sheet3 relative to Sheet2?

I'd have to understand more to help with an algorithm.

Bob
 
F

FireVic

What % match would you assign to Sheet3 relative to Sheet1?

2/5 = 40%. 10 and 20 are common out of 5 options for Sheet 3. In my sheets,
they can be in a diferent cell, not necessarly a matching cell.
What % match would you assign to Sheet3 relative to Sheet2?

1/5 = 20%. Only 10 is found in Sheet 2 that Sheet 3 has out of 5 available
options.

One thing to keep in mind is that I will constantly be adding new sheets,
and the latest sheet will be compared to the stored ones.

Thank you for taking this challenge!
 
I

INTP56

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
 
I

INTP56

Correction:
INTP56 said:
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 across to IV, then down as far as you like, but at least as far down
as the last option number.
 
F

FireVic

Hello,

Thank you for everithing.

I do not understand the part about the seacrh range Column C. Can you give
me an example?

The other thing is: Every time I create a Sheet with list of options, it
will compare to the Options or in will compare to Sheet1, Sheet2 etc.

It is impossible to have all of the avaiable options in the Options sheet
due to its size (10000+)

Thank thank you thank you for the effort. I think we are getting somewhere.
 
F

FireVic

Also, when I copyed the code, there are some lines that are red. Do you knoe
what is going on? I have Excel 2003
 
I

INTP56

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:D65536=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
 
I

INTP56

Sorry, I reread your first post and think I misunderstood what you were
trying to accomplish. For each option on the active sheet (reference page),
this determines how many times the same number of that value shows up on
other sheets, and calculates % match based on entries in ActiveSheet. How
about this code (careful with the line breaks):

Public Function OptionCounting(ws As Worksheet, Optional lngSearchColumn As
Long = 1) As Range
Dim rngActiveRange As Range, rngBottom As Range, rngTop As Range, rngArea
As Range
Dim varFrequencies As Variant, varTest As Variant, varTemp As Variant
Dim i As Long, j As Long, lngUBoundvarTest As Long, rngStart As Range
Dim rngFirstZero As Range, lngTempIdx As Long

If Left(ws.Name, 5) <> "Sheet" Then Exit Function

With ws
Application.StatusBar = "Calculating " & ws.Name
'For every entry, how many examples are there?
varFrequencies =
Application.WorksheetFunction.Frequency(.Columns(lngSearchColumn),
..Columns(lngSearchColumn))

Set rngTop = .Cells(1, lngSearchColumn)
If Not WorksheetFunction.IsNumber(rngTop) Then Set rngTop =
rngTop.End(xlDown)
Set rngBottom = rngTop.End(xlDown)
Set rngActiveRange = .Range(rngTop, rngBottom)

'This section deals with possible empty cells, in a sheet.
'If not an issue, the loop never happens.
Set rngTop = rngBottom.End(xlDown)
Do While rngTop.Row < 65535
Set rngBottom = rngTop.End(xlDown)
Set rngActiveRange = Union(rngActiveRange, .Range(rngTop, rngBottom))
Set rngTop = rngBottom.End(xlDown)
Loop
.Activate
rngActiveRange.Select
End With

lngTempIdx = 0 'This keeps track of where I am in varTemp, needed for
multiple areas
lngUBoundvarTest = rngActiveRange.Cells.Count
ReDim varTest(1 To lngUBoundvarTest, 1 To 2)
For Each rngArea In rngActiveRange.Areas 'If empty cells not an issue,
only iterates once
varTemp = rngArea.Value
For j = 1 To UBound(varTemp)
varTest(j + lngTempIdx, 1) = varTemp(j, 1)
varTest(j + lngTempIdx, 2) = varFrequencies(j + lngTempIdx, 1)
Next j
lngTempIdx = lngTempIdx + j - 1
Next rngArea

With ThisWorkbook.Worksheets(mcstrScratchName)
.Activate
.Cells.Clear
Set rngStart = .Range(.Cells(1, 1), .Cells(lngUBoundvarTest, 2))
rngStart.Value = varTest
rngStart.Sort Header:=xlNo, _
Key1:=.Cells(1, 2), Order1:=xlDescending, _
Key2:=.Cells(1, 1), Order2:=xlAscending
Set rngFirstZero = rngStart.Columns(2).Find(What:=0, LookIn:=xlValues,
LookAt:=xlWhole)
Set rngStart = rngStart.Resize(rngFirstZero.Row - 1, 2)
rngStart.Sort Header:=xlNo, Key1:=.Cells(1, 1), Order1:=xlAscending
End With
Application.StatusBar = Application.StatusBar & "... Completed"
Set OptionCounting = rngStart
End Function

Public Sub CompareOptions3()
Dim aws As Worksheet, ws As Worksheet
Dim varReference As Variant
Dim lngRefItems As Long, lngIdx As Long, i As Long, j As Long
Dim strMessageBox As String
Dim rngTest As Range
Dim sglNumMatches As Single

Set aws = ActiveSheet
If Left(aws.Name, 5) <> "Sheet" Then
MsgBox "Worksheet name must start with 'Sheet'"
Exit Sub
End If

On Error Resume Next
strMessageBox = ThisWorkbook.Worksheets(mcstrScratchName).Name
On Error GoTo 0

If strMessageBox = "" Then
ThisWorkbook.Worksheets.Add Before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Worksheets(1).Name = mcstrScratchName
End If
Application.ScreenUpdating = False

On Error Resume Next
varReference = OptionCounting(aws, 3).Value
On Error GoTo 0

If VarType(varReference) = vbEmpty Then Exit Sub

lngRefItems = UBound(varReference)
strMessageBox = "SheetName" & vbTab & "% Match"
For Each ws In aws.Parent.Worksheets
If Left(ws.Name, 5) = "Sheet" And ws.Name <> aws.Name Then
sglNumMatches = 0
Set rngTest = OptionCounting(ws, 3)
For i = 1 To lngRefItems
lngIdx = 0
On Error Resume Next
lngIdx = Application.WorksheetFunction.Match(varReference(i, 1),
rngTest.Columns(1), 0)
On Error Resume Next
If lngIdx > 0 Then
If rngTest.Cells(lngIdx, 2).Value = varReference(i, 2) Then
sglNumMatches = sglNumMatches + 1
End If
End If
Next i
strMessageBox = strMessageBox & vbCrLf & ws.Name & vbTab &
Format(sglNumMatches / lngRefItems, "0.00%")
End If
Next ws
On Error Resume Next
With Application
.DisplayAlerts = False
ThisWorkbook.Worksheets(mcstrScratchName).Delete
.DisplayAlerts = True
.StatusBar = False
.ScreenUpdating = True
End With
aws.Activate
MsgBox strMessageBox
End Sub
 
F

FireVic

Hello,

Thank you so much for the effort and the re-foucs

Please do not give up on me.

While trying to run the code I had an error message at:

ThisWorkbook.Worksheets.Add Before:=ThisWorkbook.Sheets(1)

I tryied different things and got to run but there is no result.

My email is (e-mail address removed)

is it possible for me to email you the file with the sheets (actual data)
and let you run the code for it?

Please email me so I can give the file.

Thank you so much again

Victor
 
I

INTP56

Victor,

I sent you the workbook I was using. Select a sheet of interest, and run the
macro CompareOptions3

I don't know why it bombed on Worksheets.Add, unless you were running the
code from a workbook with no sheets in it.

BTW, I use .Sheets(1) instead of .Worksheets(1) in general because I want
that sheet to be first, no matter what kind of sheets are in the workbook.
However, as Patrick noted, I should have grabbed the Worksheet as I created
it so it wouldn't matter where the worksheet was, I just didn't do it.

That code snippit should be

With ThisWorkbook
With .Worksheets.Add Before:= .Sheets(1)
.Name = mcstrScratchName
End With
End With


Bob
 
F

FireVic

Great great great!

I received your file and it is working with your data.

When I use my list of numbers the program gets "frozen". The Scratch
worksheets appears, but it just stays there.

The other thing that I noticed is that the program seems to work fine when
the list of options are in the C column. Usually the list is on A column.
When I cut and paste your list of numbers to A column it does not work.

Other than that...thank you, the program is doing exactly what I want!

Please use the following list in column A of the sheets:

Sheet1

Option Code
0030007
0003424
0014486
0007472
0020909
0020881
0588620
0009547
0020703
0011800
0010574
0070833
0020007
0005910
0023334
0024056
0002758
0004547
0011983
0009135
0007150
0002729
0030006
0000095
0065834
0004300
0012013
0072224
0013061
0091012
0024342
0072785
0012963
0012126
0004646
0085076
0018257
9901744
0007230
0062301
0013565
0000015
0000017
0078799
0062133
0010449
0023745
0081090
0039807
0005070
0059656
0051843
0051791
0011370
0051299
0008102
0005091
0045091
0025091
0002928
0013245
0004713
0046395
0033395
0042573
0020018
0011892
0017809
0006542
0062586
0009152
0080527
0000070
0004126
0004146
0004151
0001247
0003480
0053461
0500122
0551504
0067022
0007541
0004700
0004660
0004645
0029442
0004230
0004225
0014245
0017009
0005937
0052892
0005926
0071130
0006521
0070130
0052871
0075907
0005920
0005940
0091876
0075469
0009041
0005955
0029043
0021718
0002902
0058516
0032426
0031973
0028079
0013047
0029196
0092570
0092571
0010007
0005611
0032764
0073999
0003429
0007308
0089584
0035094
0085695
0008051
0028107
0006774
0028047
0044333
0091079
0091110
0091112
0045465
0092572
0092573
0029147
0029137
0027286
0006551
0032763
0029302
0029304
0012778
0092568
0092569
0064116
0009648
0092574
0092696
0064388
0039805
0039806
0004905
0005065
0024987
0003405
0004481
0036580
0090595
0034641
0005578
0005526
0039816
0005947
0089437
0020624
0020009
0024543
0051331
0092739
0035501
0032479
0091446
0004415
0008944
0022074
0082987
0017735
0013121
0004016
0013512
0033498
0000109
0013075
0072685
0014480
0073051
0014650
0020006
0013104
0006133
0016174
0029260
0001813
0029781
0051915
0074083
0065780
0031727
0018787
0006145
0013513
0031203
0022035
0005601
0073056
0073059
0024218
0063506
0037174
0055985
0003148
0012875
0505536
0024593
0004699
0005043
0016158
0004517
0084610
0003401
0032998
0080008
0065792
0021516
0004575
0020011
0083053
0083054
0076704
0027013
0072620
0005897

Sheet2

Option Code
0030007
0003424
0014486
0007472
0020909
0020881
0588620
0009547
0020703
0011800
0010574
0070833
0020007
0005910
0023334
0024056
0002758
0004547
0011983
0009135
0007150
0002729
0030006
0000095
0065834
0004300
0012013
0072224
0013061
0091012
0024342
0072785
0012963
0012126
0004646
0085076
0018257
9901745
0007230
0062301
0013565
0000015
0000017
0078799
0004710
0062133
0010449
0023745
0081090
0039807
0005070
0059656
0051843
0051791
0011370
0051299
0008102
0005091
0045091
0025091
0002928
0013245
0004713
0046395
0033395
0042573
0020018
0011892
0017809
0006542
0062586
0009152
0080527
0000070
0004126
0004146
0004152
0001247
0003480
0053461
0500122
0551504
0067022
0007541
0004660
0004645
0029442
0004230
0004225
0014245
0017007
0005937
0052892
0005926
0071130
0006521
0070130
0052871
0075907
0005920
0005940
0091876
0075469
0009041
0005955
0029043
0021718
0002902
0058516
0032426
0031973
0028079
0013047
0029196
0092570
0092571
0010007
0005611
0032764
0073999
0003429
0007308
0089584
0035094
0085695
0028107
0006774
0028047
0044333
0091079
0091110
0091112
0045465
0092572
0092573
0029147
0029137
0027286
0006551
0032763
0029302
0029304
0012778
0092568
0092569
0064116
0009648
0092574
0092696
0064388
0039805
0039806
0004905
0005065
0024987
0003405
0004481
0036580
0090595
0034641
0035574
0005526
0039816
0005947
0089437
0020624
0020009
0024543
0051331
0035501
0025088
0032479
0091446
0004415
0008944
0022074
0082987
0017735
0013121
0004016
0013512
0033498
0000109
0013075
0072685
0014480
0073051
0014650
0013104
0006133
0016174
0029260
0001813
0029781
0051915
0074083
0012771
0065780
0031727
0018787
0006145
0013513
0031203
0022035
0005601
0073056
0073059
0020005
0024218
0063506
0037174
0055985
0003148
0012875
0505536
0024593
0004699
0005043
0004687
0004517
0084610
0003401
0032998
0080008
0065792
0021516
0004575
0020011
0083053
0083054
0076704
0027013
0072620
0005897

Sheet3

Option Code
0074083
0000095
0018257
0028079
0062301
0008051
0588620
9901747
0010007
0080008
0030006
0029442
0000109
0076705
0000070
0011892
0092457
0011983
0018787
0073051
0014139
0024218
0012428
0008102
0020881
0012013
0002992
0009547
0011800
0010574
0013245
0070833
0033395
0001247
0081090
0017809
0023745
0055985
0024593
0012875
0021516
0011370
0001813
0073056
0083054
0073061
0083053
0015772
0024342
0008903
0027014
0013047
0013061
0072224
0037174
0021384
0016223
0065736
0033498
0005940
0020703
0091012
0034641
0072620
0013104
0072685
0002729
0012778
0023334
0032763
0024056
0002758
0072785
0052892
0005910
0509860
0509886
0002902
0002928
0008944
0022035
0003405
0028107
0003401
0003429
0003424
0030007
0053461
0003480
0059656
0551504
0013512
0013513
0063506
0013565
0051299
0051331
0051791
0022074
0051843
0004016
0004152
0004126
0004146
0004225
0004230
0004300
0014245
0064388
0051915
0004415
0004481
0091446
0505536
0014480
0003148
0004547
0014486
0004517
0010449
0024543
0004575
0058516
0020624
0089437
0032998
0004645
0004646
0014650
0084610
0004660
0029147
0004687
0004710
0092569
0092696
0064116
0009648
0092568
0004699
0029043
0004905
0039805
0092570
0039806
0092571
0029137
0092572
0024987
0092574
0092573
0085076
0005043
0005091
0035094
0025091
0089584
0045091
0085695
0007308
0062133
0005065
0029302
0029304
0005070
0039807
0029196
0029260
0500122
0044333
0509094
0042573
0045465
0091110
0091079
0091112
0025088
0032479
0005526
0035574
0035501
0080527
0005601
0007541
0511078
0511100
0062586
0006774
0017007
0005897
0009041
0031203
0075907
0091876
0005937
0005926
0005920
0071130
0005947
0039816
0005955
0006133
0021718
0006145
0016174
0052871
0070130
0075469
0006521
0006551
0082987
0007150
0067022
0048169
0090595
0065653
0007230
0017735
0013121
0065785
0027286
0007472
0078799
0000017
0000015
0004713
0046395
0020011
0020009
0028047
0020005
0020007
0020909
 
I

INTP56

Victor,

2 things,

1) You need to pass a column into the function that analyzes the sheets, so
I changed that to 1 instead of 3.

2) I was expecting dupilcates to be in the sheets, and didn't code for what
would happen if there were no duplicates. I test for that case now. I sent
you a new workbook with the code and your data set.

Bob
 
F

FireVic

Thank you! The code is working to perfection!

But when I import from oracle, the fileds are formated as text, not numbers.

In order for the code to work I have to multiply by 1 in column 2 and put
the resutls in column 1.

The standard cell formating is not helping (from text to numbers)

Is there something in the code that can be changed so it can accept and
compare text?

This is the last inquiry that I will do and thank you so much for your time
and effort.

Respectfully,

Victor
 
F

FireVic

Thank you so much! The code is working super!

What can I change in the code so it can recognize strings of text instead of
numbers? (right now the numbers are being imported as text form the database).

This is the last replay. Thank you so much for everything. ..

Victor
 
I

INTP56

Victor,

I sent you another workbook that includes making all the numbers formatted
as text be seen as numbers.

You don't have this case in your example data, but I allowed for breaks in
the lists, and you should see that in the sample data I used. I fixed a bug
in the logic that would incorrectly determine range areas if the range area
in question had only one cell in it. Now, that works correctly.

I'm including the code as it now stands.

Bob



'*******************************************************
Option Explicit
Private Const mcstrScratchName As String = "Scratch"

Public Function OptionCounting2(ws As Worksheet, Optional lngSearchColumn As
Long = 1) As Range
Dim rngActiveRange As Range, rngBottom As Range, rngTop As Range, rngArea
As Range
Dim varFrequencies As Variant, varTest As Variant, varTemp As Variant,
rngTotalRange As Range
Dim i As Long, j As Long, lngUBoundvarTest As Long, rngStart As Range
Dim rngFirstZero As Range, lngTempIdx As Long, varConvert As Variant

If Left(ws.Name, 5) <> "Sheet" Then Exit Function

Set rngBottom = ws.Cells(ws.Cells.SpecialCells(xlCellTypeLastCell).Row,
lngSearchColumn)
Set rngTotalRange = ws.Range(ws.Cells(1, lngSearchColumn), rngBottom)
With rngTotalRange
ThisWorkbook.Worksheets("Scratch").Range(.Address).ClearContents
.Copy
ThisWorkbook.Worksheets("Scratch").Range(.Address).PasteSpecial
Operation:=xlAdd
.Value = ThisWorkbook.Worksheets("Scratch").Range(.Address).Value
End With

With ws
Set rngTop = .Cells(1, lngSearchColumn)
If Not WorksheetFunction.IsNumber(rngTop.Value) Then
Set rngTop = rngTop.End(xlDown)
End If

If Application.WorksheetFunction.IsNumber(rngTop.Offset(1, 0)) Then
Set rngBottom = rngTop.End(xlDown)
Else
Set rngBottom = rngTop
End If

Set rngActiveRange = .Range(rngTop, rngBottom)

Set rngTop = rngBottom.End(xlDown)
Do While rngTop.Row < 65535

If Application.WorksheetFunction.IsNumber(rngTop.Offset(1, 0)) Then
Set rngBottom = rngTop.End(xlDown)
Else
Set rngBottom = rngTop
End If

Set rngActiveRange = Union(rngActiveRange, .Range(rngTop, rngBottom))

Set rngTop = rngBottom.End(xlDown)
Loop

'.Activate
'rngActiveRange.Select

Application.StatusBar = "Calculating " & .Name
'For every entry, how many examples are there?
varFrequencies =
Application.WorksheetFunction.Frequency(.Columns(lngSearchColumn),
..Columns(lngSearchColumn))
End With

lngTempIdx = 0 'This keeps track of where I am in varTemp, needed for
multiple areas
lngUBoundvarTest = rngActiveRange.Cells.Count
ReDim varTest(1 To lngUBoundvarTest, 1 To 2)
For Each rngArea In rngActiveRange.Areas 'If empty cells not an issue,
only iterates once
If rngArea.Cells.Count = 1 Then
'If there is only one cell in a range, then the variant needs to be
redim'd explicitly
ReDim varTemp(1 To 1, 1 To 1)
varTemp(1, 1) = rngArea.Value
Else
'Else it will be implicitly redim'd a 2 dimension array.
varTemp = rngArea.Value
End If
For j = 1 To UBound(varTemp)
varTest(j + lngTempIdx, 1) = varTemp(j, 1)
varTest(j + lngTempIdx, 2) = varFrequencies(j + lngTempIdx, 1)
Next j
lngTempIdx = lngTempIdx + j - 1
Next rngArea

With ThisWorkbook.Worksheets(mcstrScratchName)
.Activate
.Cells.Clear
Set rngStart = .Range(.Cells(1, 1), .Cells(lngUBoundvarTest, 2))
rngStart.Value = varTest
rngStart.Sort Header:=xlNo, _
Key1:=.Cells(1, 2), Order1:=xlDescending, _
Key2:=.Cells(1, 1), Order2:=xlAscending
Set rngFirstZero = rngStart.Columns(2).Find(What:=0, LookIn:=xlValues,
LookAt:=xlWhole)
If Not rngFirstZero Is Nothing Then
Set rngStart = rngStart.Resize(rngFirstZero.Row - 1, 2)
End If
.Activate
rngStart.Select
rngStart.Sort Header:=xlNo, Key1:=.Cells(1, 1), Order1:=xlAscending
End With
Application.StatusBar = Application.StatusBar & "... Completed"
Set OptionCounting2 = rngStart
End Function

Public Sub CompareOptions3()
Dim aws As Worksheet, ws As Worksheet
Dim varReference As Variant
Dim lngRefItems As Long, lngIdx As Long, i As Long, j As Long
Dim strMessageBox As String
Dim rngTest As Range
Dim sglNumMatches As Single

Set aws = ActiveSheet
If Left(aws.Name, 5) <> "Sheet" Then
MsgBox "Worksheet name must start with 'Sheet'"
Exit Sub
End If

On Error Resume Next
strMessageBox = ThisWorkbook.Worksheets(mcstrScratchName).Name
On Error GoTo 0

If strMessageBox = "" Then
ThisWorkbook.Worksheets.Add Before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Worksheets(1).Name = mcstrScratchName
End If
Application.ScreenUpdating = False

On Error Resume Next
varReference = OptionCounting2(aws, 1).Value
On Error GoTo 0

If VarType(varReference) = vbEmpty Then Exit Sub

lngRefItems = UBound(varReference)
strMessageBox = "SheetName" & vbTab & "% Match"
For Each ws In aws.Parent.Worksheets
If Left(ws.Name, 5) = "Sheet" And ws.Name <> aws.Name Then
sglNumMatches = 0
Set rngTest = OptionCounting2(ws, 1)
For i = 1 To lngRefItems
lngIdx = 0
On Error Resume Next
lngIdx = Application.WorksheetFunction.Match(varReference(i, 1),
rngTest.Columns(1), 0)
On Error Resume Next
If lngIdx > 0 Then
If rngTest.Cells(lngIdx, 2).Value = varReference(i, 2) Then
sglNumMatches = sglNumMatches + 1
End If
End If
Next i
strMessageBox = strMessageBox & vbCrLf & ws.Name & vbTab &
Format(sglNumMatches / lngRefItems, "0.00%")
End If
Next ws
On Error Resume Next
With Application
.DisplayAlerts = False
ThisWorkbook.Worksheets(mcstrScratchName).Delete
.DisplayAlerts = True
.StatusBar = False
.ScreenUpdating = True
End With
aws.Activate
MsgBox strMessageBox
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top