computing ratio for samples with many subrecords

[Guest]

This is somewhat complicated for a newbie to VBA or excel programming like
myself. I have data in excel that is arranged much like this below:

sample comp hzname
1 a A1
1 a A2
1 a Bt1
1 a Bt2
1 a R
2 b A
2 b Bt1
2 b Bt2
3 a A1
3 a A2
3 a Bt1
3 a Bt2
3 a R
4 a A1
4 a A2
4 a BC
4 a Bt

What I would like to do, probably with VB code because this will be expanded
upon, is compute a ratio that answers the question, "How many of the
"samples" with a "comp" value of "a" have a "hzname" value of "R", out of all
samples with comp value of a?" The thing that is tripping me up in
programming is that there are only 4 samples here, each sample has many
records. So the answer I am looking for in this example is "2 out of 3
samples with comp a have a hzname of R". I would then put the result in a
open cell in the spreadsheet. Any help??

 

[Guest]

Have you looked at pivoting the data. With pivots you can select do std dev
and percentages of. Not sure if this will help, but it might be worth a try...

 

[Guest]

Hi Giz,
This is not a code oriented solution:
sample comp hzname No
1 a A1 1
1 a A2 1
1 a Bt1 1
1 a Bt2 1
1 a R 1
2 b A 1
2 b Bt1 1
2 b Bt2 1
3 a A1 1
3 a A2 1
3 a Bt1 1
3 a Bt2 1
3 a R 1
4 a A1 1
4 a A2 1
4 a BC 1
4 a Bt 1

Ct Value Ct
TotalCt 17 =COUNT(A2:A18)
a 14 =COUNTIF(B1:B18,A22)
a & R 2 {=SUM(IF($B$2:$B$18="a",IF($C$2:$C$18="R",$D$2:$D$18,0),0))}
a&R/TotalCt 0.117647059 =+B23/B21

The extra column "D" is a cheat column and is used to "count" values by
adding the 1s together. The row "A & R" is an array entered formula, so you
need to do Ctrl+Shirt+Enter at the same time. It is a little hard to rea
above, so this is what it looks like again:
{=SUM(IF($B$2:$B$18="a",IF($C$2:$C$18="R",$D$2:$D$18,0),0))}
Hope this helps.
Thanks,

 

[Guest]

The reason I was thinking it may be a code oriented solution is because I
want to count the occurance of R in every "unique" sample value that has comp
a. So instead of computing the ratio of R to total number, or count, of rows
(the answer of .117647), it would be occurances of R to the THREE samples
with comp a (sample values of 1, 3, and 4 in this example). So answer would
be .666666. So I need more than count of rows, I need a count of unique
sample values and then a test for comp a. I hope this makes sense.

 

[Guest]

Hi Giz,
Think you are right, the only way I could see to do it was with code. Try
this and see if it works for you.

Sub Unique()
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(3, 0).Range("A1").Select
ThisRow = ActiveCell.Row
ActiveCell.Value = "a&R"
ActiveCell.Offset(0, 1).Range("A1").Select
ReturnAddress = ActiveCell.Address
Selection.FormulaArray = _
"=SUM(IF(R2C2:R" & (ThisRow - 3) & "C2=""a"",IF(R2C3:R" & (ThisRow - 3)
& "C3=""R"",R2C4:R" & (ThisRow - 3) & "C4,0),0))"
Range("A1").Select
n = 1
Ct = 0
ActiveCell.Offset(1, 0).Select
Dim SRC()
Do Until ActiveCell.Value = ""
For z = n To (n + 1)
ReDim Preserve SRC(n)
SRC(n) = ActiveCell.Value & ActiveCell.Offset(0, 1).Value
For a = 1 To z
If a = z Then GoTo SkipIt
If SRC(a) = SRC(z) Or Right(SRC(z), 1) <> "a" Then
SRC(z) = ""
Else
End If
SkipIt:
Next
ActiveCell.Offset(1, 0).Select
n = n + 1
Next
Loop
Stop
For q = 1 To (n - 1)
If SRC(q) <> "" Then
Ct = Ct + 1
End If
Next
Stop
Range(ReturnAddress).Select
ActiveCell.Offset(1, -1).Select
ActiveCell.Value = "Unqa&R"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value / Ct
End Sub

Thanks

 

[Guest]

Hi David,
I tried your code and tried to follow step by step the procedure. It seems
that when run the macro on the datasheet the procedure "stops" at the first
stop command. How can we make the procedure "keep going"? Then when I
manually proceeded (i.e. hit the run button in VB editor, procedure results
on the datasheet produced values of "0" in both "a&R" and "Unqa&R" cells.

I went back and ran the
=SUM(IF($B$2:$B$18="a",IF($C$2:$C$18="R",$D$2:$D$18,0),0)) function
on dataset (I didn't do that after your first reply) just to see if that
function would work, and I get a "VALUE" error. I adjusted values around
(i.e. "a" to a) and no luck. To test I ran a simple function on one row
=IF($B$6="a",IF($C$6="R",$D$6,0),0)
to see if "IF" function would work to designate "1" when R present, and it
did. So I think there is something awry when either add range of cells OR the
SUM function. I am trying to figure out now. Any insights??

 

[Guest]

Hi Giz,
Forgot to take out the stops that i had used to test it, also i had assumed
the data is laid out in a certain way. The upper left hand corner is "A1" and
the 1s under No are numbers:
sample comp hzname No
1 a A1 1
1 a A2 1
1 a Bt1 1
1 a Bt2 1
1 a R 1
2 b A 1
2 b Bt1 1
2 b Bt2 1
3 a A1 1
3 a A2 1
3 a Bt1 1
3 a Bt2 1
3 a R 1
4 a A1 1
4 a A2 1
4 a BC 1
4 a Bt 1

Code with out stops:

Sub Unique()
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(3, 0).Range("A1").Select
ThisRow = ActiveCell.Row
ActiveCell.Value = "a&R"
ActiveCell.Offset(0, 1).Range("A1").Select
ReturnAddress = ActiveCell.Address
Selection.FormulaArray = _
"=SUM(IF(R2C2:R" & (ThisRow - 3) & "C2=""a"",IF(R2C3:R" & (ThisRow - 3)
& "C3=""R"",R2C4:R" & (ThisRow - 3) & "C4,0),0))"
Range("A1").Select
n = 1
Ct = 0
ActiveCell.Offset(1, 0).Select
Dim SRC()
Do Until ActiveCell.Value = ""
For z = n To (n + 1)
ReDim Preserve SRC(n)
SRC(n) = ActiveCell.Value & ActiveCell.Offset(0, 1).Value
For a = 1 To z
If a = z Then GoTo SkipIt
If SRC(a) = SRC(z) Or Right(SRC(z), 1) <> "a" Then
SRC(z) = ""
Else
End If
SkipIt:
Next
ActiveCell.Offset(1, 0).Select
n = n + 1
Next
Loop
For q = 1 To (n - 1)
If SRC(q) <> "" Then
Ct = Ct + 1
End If
Next
Range(ReturnAddress).Select
ActiveCell.Offset(1, -1).Select
ActiveCell.Value = "Unqa&R"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value / Ct
End Sub

Thanks

 

[Guest]

OK, changed format of the "no" column to numbers. That seemed to fix problem
in "a&R" cell. The "Unqa&R" cell is still a value of "0", however. Looking at
other formatting and code to try to decipher why

 

[Guest]

Hi Giz,
Added a single line of code to format the cell in question. Hope this will
fix the problem.
Sub Unique()
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(3, 0).Range("A1").Select
ThisRow = ActiveCell.Row
ActiveCell.Value = "a&R"
ActiveCell.Offset(0, 1).Range("A1").Select
ReturnAddress = ActiveCell.Address
Selection.FormulaArray = _
"=SUM(IF(R2C2:R" & (ThisRow - 3) & "C2=""a"",IF(R2C3:R" & (ThisRow - 3)
& "C3=""R"",R2C4:R" & (ThisRow - 3) & "C4,0),0))"
Range("A1").Select
n = 1
Ct = 0
ActiveCell.Offset(1, 0).Select
Dim SRC()
Do Until ActiveCell.Value = ""
For z = n To (n + 1)
ReDim Preserve SRC(n)
SRC(n) = ActiveCell.Value & ActiveCell.Offset(0, 1).Value
For a = 1 To z
If a = z Then GoTo SkipIt
If SRC(a) = SRC(z) Or Right(SRC(z), 1) <> "a" Then
SRC(z) = ""
Else
End If
SkipIt:
Next
ActiveCell.Offset(1, 0).Select
n = n + 1
Next
Loop
For q = 1 To (n - 1)
If SRC(q) <> "" Then
Ct = Ct + 1
End If
Next
Range(ReturnAddress).Select
ActiveCell.Offset(1, -1).Select
ActiveCell.Value = "Unqa&R"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value / Ct
ActiveCell.NumberFormat = "0.0%"
End Sub
Thanks,