Selecting a set of cells from a column of values 1

[Eytch]

I work in a laboratory. A duplicate is ran on each set of samples. How do I select a range of samples from a column of results, perform quality calculations, flag the samples of the current set if necessary and then move on to the next set?

Dish # Result Flag
1 20
2 31
3 22
3 26
4 19
5 17
6 12
7 25
7 31

The first set would consist of samples 1-3. A relative percent difference calculation is performed on the results of samples 3 and its duplicate. If it does not meet acceptance criteria samples 1-3 are flagged "AD" - duplicates out of control. The program then goes on and tests samples 4-7, the next set. How do I get the "Loop to start after the first set of duplicates (in this case sample number 3) and perform the operation again?

 

[Loomah]

Hi

Not 100% sure what you require but I think I got it here! Assuming data in column B and test Number/Dish in column A this should give a flag in column C - he says hopefully!

You WILL need to check my calculation method!

Sub CheckDupes()
Dim c As Range
Dim lRow As Long
Dim firstcell
lRow = [a65536].End(xlUp).Row
firstcell = "C1"
For Each c In Range(Cells(1, 1), Cells(lRow, 1))
    If c.Offset(1, 0) = c And _
        (c.Offset(1, 1) - c.Offset(0, 1)) / c.Offset(0, 1) > 0.05 Then '5% tolerance
            Range(firstcell & ":" & c.Offset(0, 2).Address) = "AD"
            firstcell = c.Offset(2, 2).Address
    End If
Next c
End Sub

;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Thanks Loomah,
Samples 1 through 3 belong to set 1 and 4-7 to set 2. A duplicated dish # signifies the end of a set. If the duplicates are out of control then all samples of the corresponding set are to be flagged "AD". If they are not out of control the program resumes at the first sample after set 1 (in this case at dish 4) tests the duplicates corresponding to set 2, flags if necessary, then moves on, etc... My programming problem is to randomly get it to start at the next sample beyond duplicates, i.e., at dish #4 after performing the calculations (and flagging if necessary)for set 1 on duplicate dishes #3. You are exactly right on the type of calculation I wish to perform but I need to get it to apply the QC to all samples of the set before it tests the next one. If dish 3 duplicates are out then dishes 1-3 are flagged "AD", if dish 7 duplicates are out then dishes 4-7 are flagged "AD", etc...

Thanks Much!
Tripoli

 

[Loomah]

tripoli
if you haven't used my code to see what it does then basically it will find the duplicates and then preform the calculation there, in you example comparing the two 3s and two 7s and flag 1-3 & 4-7 if appropriate.

are you wanting to perform the tests on all dishes in the set ie when the code finds the end of set 1 (ie #3) it compares 1 to 3, 2 to 3 & 3 to 3?? i hope not!!

unfortunately i'm in england (that's not unfortunate in itself other than the fact the hockey here isn't really worth watching!) and i need something to eat as it 9 pm here so i think i'll be off line for today. test the code i've given if you haven't already, it worked with picing out the duplicates and performing A calculation and flagging - it may be the answer. if not post back and i'll be around possibly tomorrow!

;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Loomah,
I tried your code using values other than those I gave in the example. Try your code on the following data:

Dish# Result Flag
1 20
2 31
3 25
3 26
4 17
5 12
6 25
7 33
7 38

The calculation I wish to perform is the relative percent difference, for dish number 7:

Abs((33-38)/((33+38)/2))=0.14

Since this is greater than the 5% acceptance criteria samples 4 through 7 (including the duplicated 7) would be flagged "AD". Since the duplicates for sample 3 are within the 5% limit, samples 1 through 3 are not flagged. I hope this gives you a better idea of what I'm after.

Thanks Again!
Tripoli

 

[Loomah]

I think I've cracked it at last!! The following shows how bad my first posting was. I've tested this with extended and varying lists of data and it appears ok!

If you want the full workings, post your email address and I'll send you the file so you can see the testing.

I hope this works out as I've quite enjoyed the challenge! It's no wonder I can't get a job!!

Option Explicit

Sub CheckDupesV3()
'checks columns for duplicates
'compares percentage difference
'if diff excedes tolerance then flag cells back to last check
Dim c As Range
Dim sngToll As Single
Dim lRow As Long
Dim firstcell as string
Dim bFstCell As Boolean

Worksheets("Data").Activate
' initiate variable values
lRow = [a65536].End(xlUp).Row
firstcell = "C1"
bFstCell = True 'used to enable firstcell to be reset when dupes are found
sngToll = 0.05 '5% tolerance

'clear previous flags IF APPROPRIATE
Range(Cells(1, 3), Cells(lRow, 3)).ClearContents
'loop froo cells
For Each c In Range(Cells(1, 1), Cells(lRow, 1))
    If bFstCell And c.Offset(1, 0) = c Then
        If PcntDiff(c.Offset(0, 1), c.Offset(1, 1)) > sngToll Then
            Range(firstcell & ":" & c.Offset(1, 2).Address) = "AD"
        End If
        firstcell = c.Offset(2, 2).Address
        bFstCell = False
    ElseIf c.Offset(1, 0) = c Then
        If PcntDiff(c.Offset(0, 1), c.Offset(1, 1)) > sngToll Then
            Range(firstcell & ":" & c.Offset(1, 2).Address) = "AD"
        End If
        firstcell = c.Offset(2, 2).Address
        bFstCell = True
    End If
Next c
End Sub

Function PcntDiff(oldVal As Single, newVal As Single) As Single
'basic percent difference calc
PcntDiff = Abs((newVal - oldVal) / oldVal)
' your alternative
'PcntDiff = Abs((oldVal - newVal) / ((oldVal + newVal) / 2))
End Function

;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Loomah]

Just looked at this again and refined it....

Option Explicit
Dim c As Range

Sub CheckDupesV4()
'checks columns for duplicates
'compares percentage difference
'if diff excedes tolerance then flag cells back to last check
Dim sngToll As Single
Dim lRow As Long
Dim firstcell As String

Worksheets("Data").Activate
' initiate variable values
lRow = [a65536].End(xlUp).Row
firstcell = "C1"
sngToll = 0.05 '5% tolerance

'clear previous flags IF APPROPRIATE
Range(Cells(1, 3), Cells(lRow, 3)).ClearContents
'loop froo cells
For Each c In Range(Cells(1, 1), Cells(lRow, 1))
    If c.Offset(1, 0) = c Then
        If PcntDiff > sngToll Then
            Range(firstcell & ":" & c.Offset(1, 2).Address) = "AD"
        End If
        firstcell = c.Offset(2, 2).Address
    End If
Next c
End Sub

Function PcntDiff() As Single
Dim oldVal As Single
Dim newVal As Single
oldVal = c.Offset(0, 1)
newVal = c.Offset(1, 1)
'basic percent difference calc
PcntDiff = Abs((newVal - oldVal) / oldVal)
' your alternative
'PcntDiff = Abs((oldVal - newVal) / ((oldVal + newVal) / 2))
End Function

Close to the original so I wasn't that far off first time round!!
;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Loomah,

Your revision works great! I had to incorporate the function into the if statements to get your first revision to click but I realize that process is redundant. I'll post the entire completed program when I finish. Your help has been invaluable to its completion. Before I came to you my version would flag all sets prior to the last one that had duplicates out of control. I will now attach the other calculations to the program to complete it. I welcome any comments or suggestions you may have after I post that version. I am a novice at this stuff. I'm at the stage where I know what I want and know it is possible but sometimes have a hard time getting there! Your program is invaluable-can't thank you enough. This guy is worth hiring!

Thanks Loomah,
Tripoli

 

[DaleWatson123321]

Tripoli,

Because you're new to Tek-Tips, it's a good reason for not being aware of the "proper" method of saying thanks and giving recognition to a Tek-Tips contributor.

The method is quite simple - just click on the "*Mark this post as a helpful/expert post!" - located in the lower-left-corner of the contributor's posting. This results in the awarding of one of those "shiny Purple STARS" you probably have noticed. These STARS also serve as a sort of "beacon" to notify others than a solution has been provided, and will be of interest to everyone, including members who are on the lookout for useful solutions.

After seeing your comments about Loomah... "Your program is invaluable-can't thank you enough. This guy is worth hiring!"... I'm confident you'll be pleased to know of this "proper" way of saying thanks.

Regards, ...Dale Watson dwatson@bsi.gov.mb.ca

 

[Eytch]

Loomah,

How would the code be modified to accomodate several intervening colums of data (a random number of intervening data columns)? The first column would still be the dish number and the last the final result. The program would sort based on the dish number and corresponding final result as it does now and place a flag if appropriate in the column beyond the final result.

Dish# Tare Wt. Final Wt. Volume Result Flag
1 20 30 100 15 AD
1 10 40 100 25 AD
2 30 50 100 30


The final output would appear as above.

Thanks,
Tripoli

 

[Loomah]

Hi Tripoli
I'm not really in a position to deal with this today but some pointers might help you

Find the last column containing data. assuming headings (which I didn't originally) in row 1 then

LastCol = [a1].end(xltoright).column

should be ok. For other ways see the FAQs for this forum.

Change the default value of firstcell to

=cells(1,lastcol)

The clear contents part will need to be change to reference lastcol instead of 3

The offset command to position the flag will tae slightly more thought as will reassigning a value to firstcell.

Hopefully I'll get a chance to look at this more fully over the weekend (coz I am that sad!) and get back to you.

Happy Friday
;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Loomah]

Change the default value of firstcell to =cells(1,lastcol)

should be

=cells(1,lastcol).address

Happy Friday
;-)

If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Loomah,

Initially a dish would be assigned to a sample in numerical order. If they were analyzed at random thereafter a sort would be required before calculation and assignment of a quality control flag. I used "CurrentRegion" to first select the dataset and then "Selection.Sort" to sort it. Selection.Sort has a parameter that allows you to ignore Headers.

Thanks Again,
Tripoli

 

[Loomah]

Tripoli
Here is an updated version to cope with any number of columns up to 256.

I've tried to label where I've amended and where I've added to the routine. You'll need to copy into a module to see this!

Give it a go and let me know how you get on.

Option Explicit
Dim c As Range
Dim iCol As Integer 'added

'============================================================
' Revision to cope with multiple columns of data
' includes allowance for headings in row 1
' assumes headings are in place and last heading is "FLAG"
'
' Revised 15 Feb 2003 (and yes, it is a Saturday!!)
'============================================================

Sub CheckDupesV5()
'checks columns for duplicates
'compares percentage difference
'if diff excedes tolerance then flag cells back to last check
Dim sngToll As Single
Dim lRow As Long
Dim firstcell As String

Application.ScreenUpdating = False 'added
    Worksheets("Data2").Activate
    ' initiate variable values
    lRow = [a65536].End(xlUp).Row
    sngToll = 0.05 '5% tolerance
    'get last col in row 1 allowing for blanks
    iCol = Rows(1).Cells.Find("*", [a1], xlValues, , xlByColumns, xlPrevious).Column 'added
    firstcell = Cells(2, iCol).Address 'row 2 as row 1 are headers
                                        'amended
                                        
    'clear previous flags IF APPROPRIATE
    Range(Cells(2, iCol), Cells(lRow, iCol)).ClearContents 'amended
    'loop froo cells
    For Each c In Range(Cells(2, 1), Cells(lRow, 1)) 'cells in col A ie dish No.
                                                     'amended
        If c.Offset(1, 0) = c Then
            If PcntDiff > sngToll Then
                Range(firstcell & ":" & c.Offset(1, iCol - 1).Address) = "AD" 'amended
            End If
            firstcell = c.Offset(2, iCol - 1).Address 'amended
        End If
    Next c
Application.ScreenUpdating = True 'added
End Sub

Function PcntDiff() As Single
Dim oldVal As Single
Dim newVal As Single
oldVal = c.Offset(0, iCol - 2) 'amended
newVal = c.Offset(1, iCol - 2) 'amended
'basic percent difference calc
PcntDiff = Abs((newVal - oldVal) / oldVal)
' your alternative
'PcntDiff = Abs((oldVal - newVal) / ((oldVal + newVal) / 2))
End Function

;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Loomah,

I have thought of another variation on this. In our lab the regulators require a duplicate every 20 samples or one per batch if there are fewer than 20 in the set being analyzed. The sample chosen for duplication should be a random selection. Say I chose #5 as the duplicate for the first 20 samples and 31 for samples 21-40. The data for the duplicated sample would appear immediately after the 20 samples contained within the set. As an example, say there were only 5 samples to a set (instead of 20):

Dish # Initial Final Result Flag
1 1 2 3 AD
2 1 2 3 AD
3 1 2 6 AD
4 1 2 3 AD
5 1 2 3 AD
3 1 2 3 AD
6 1 2 3
7 1 2 3
8 1 2 3
9 1 2 3
10 1 2 3
7 1 2 3

In this example samples 1-5 comprise set 1. Sample 3 is the duplicate in this set and the duplicate results will always appear after the last member of the set (the duplicate results for sample 3 appear after sample 5). Since the result for sample 3 and its duplicate do not meet control criteria all samples of the set are flagged. Unlike previous examples the duplicate in this example appears after the last sample of the set not immediately after the sample that was duplicated. Since the duplicate of the second set (#7) and its duplicate were not out of control the members of the second set (samples 6-10)are not flagged. I hope I can one day present you with a challenge!

Once again,
Thanks
Tripoli

 

[Eytch]

Loomah,

The location of the duplicated sample marks the end of the set. If the original sample and its duplicate did not meet control criteria all members of that set would be flagged. A set would extend from the duplicated sample back to the duplicate of the previous set. All samples of the set not meeting control limit criteria would be flagged "AD".

Some Clarification,
Thanks,
Tripoli

 

[Loomah]

Tripoli
I will have a look at this but it may be next week. Working at the moment and going away this weekend. May have a chance tomorrow (Tuesday) night.

It shouldn't be too hard (famous last words!) to amend what you already have.

;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Eytch]

Loomah,

The following code allows me to check each number in a column for a duplicate. However, it does this by returning to the first cell in the column before checking the next cell instead of beginning at the location of the first cell after the duplicate. To give you an idea of the stage of my programming...

Sub asd()

R = 1

Do

Cells.Find(What:=Cells(R, 1), After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate

Cells.FindNext(After:=ActiveCell).Activate
Cells(1, 1).Select

R = R + 1

If R = Cells.End(xlDown).Row Then
Exit Do
End If

Loop

End Sub

Still trying to come up with the solution for my proposal on the 23rd of February. Just wanted to let you know by evidence of this code that I do take shots at it!

Thanks Again,
Tripoli

 

[Loomah]

Tripoli
As promised!!

After the most mind numbingly dull day at work I needed something worthwhile to do. Shouldn't really complain after so long without any work!!!

This is built onto the last version and will find the duplicate and perform the relevant calc. The assumption is that all the dish numbers are in order apart from the duplicate, which it is assumed follows on from the rest of the batch.

I think this will fall over if there are empty rows, so keep your data properly grouped!! I haven't tested this though.

I haven't looked at your code in great detail but I suspect (part of) the problem with going back to the beginning all the time is that you select cell A1 (Cells(1, 1).Select) within your loop.

Anyway here's my '(I'm) rather tired now' amendment!
Good Luck

Option Explicit
Dim c As Range
Dim iCol As Integer
Dim lDishRow As Long

'============================================================
' Revision to cope with control dish not being last one
' in the batch ie in a batch of 1-10 dishes the control
' may be 4 or might still be 10 but......
'
' Revised 4 March 2003
'============================================================

Sub CheckDupesV6()
'checks columns for duplicates
'compares percentage difference
'if diff excedes tolerance then flag cells back to last check
Dim sngToll As Single
Dim lRow As Long
Dim firstcell As String
Dim lQCDish As Long

Application.ScreenUpdating = False
    Worksheets("Data3").Activate
    ' initiate variable values
    lRow = [a65536].End(xlUp).Row
    sngToll = 0.05 '5% tolerance
    'get last col in row 1 allowing for blanks
    iCol = Rows(1).Cells.Find("*", [a1], xlValues, , xlByColumns, xlPrevious).Column
    firstcell = Cells(2, iCol).Address 'row 2 as row 1 are headers
                                      
    'clear previous flags IF APPROPRIATE
    Range(Cells(2, iCol), Cells(lRow, iCol)).ClearContents
    'loop froo cells
    For Each c In Range(Cells(2, 1), Cells(lRow, 1))  'cells in col A ie dish No.
        
        'see what the number of the next dish is
        lQCDish = c.Offset(1, 0)
        'avoid looking for nothing at end of tests!!
        'assumes dishes in order apart from duplicate
        'this allows for assumption that next dish will be higher num than current (c)
        If Not lQCDish = 0 And lQCDish <= c Then
        'find ROW for original occurence of duplicate dish
        lDishRow = Columns(&quot;A&quot;).Cells.Find(lQCDish, c.Offset(1, 0), , xlWhole, xlByRows, xlPrevious).Row
            If PcntDiff > sngToll Then
                Range(firstcell & &quot;:&quot; & c.Offset(1, iCol - 1).Address) = &quot;AD&quot;
            End If
            firstcell = c.Offset(2, iCol - 1).Address
        End If
    Next c
Application.ScreenUpdating = True
End Sub

Function PcntDiff() As Single
Dim oldVal As Single
Dim newVal As Single
oldVal = Cells(lDishRow, iCol - 1)
newVal = c.Offset(1, iCol - 2)
'basic percent difference calc
PcntDiff = Abs((newVal - oldVal) / oldVal)
' your alternative
'PcntDiff = Abs((oldVal - newVal) / ((oldVal + newVal) / 2))
End Function

;-) If a man says something and there are no women there to hear him, is he still wrong?