Path: csiph.com!x330-a1.tempe.blueboxinc.net!newsfeed.hal-mli.net!feeder3.hal-mli.net!newsfeed.hal-mli.net!feeder1.hal-mli.net!eternal-september.org!feeder.eternal-september.org!mx04.eternal-september.org!.POSTED!not-for-mail
From: GS <gs@somewhere.net>
Newsgroups: comp.lang.basic.visual.misc
Subject: Re: For..Each vs For..Next with Collections
Date: Sun, 26 Feb 2012 17:06:59 -0500
Organization: A noiseless patient Spider
Lines: 139
Message-ID: <jieae4$9vm$1@dont-email.me>
References: <jiblhc$pfa$1@dont-email.me>
Mime-Version: 1.0
Content-Type: text/plain; charset="iso-8859-15"; format=flowed
Content-Transfer-Encoding: 8bit
Injection-Date: Sun, 26 Feb 2012 22:07:01 +0000 (UTC)
Injection-Info: mx04.eternal-september.org; posting-host="UVJBuiIZprDyxzUkJsiwfw"; logging-data="10230"; mail-complaints-to="abuse@eternal-september.org";	posting-account="U2FsdGVkX19bf9wpWAd99uJuEcCv/Ehr"
X-Antivirus-Status: Clean
X-Newsreader: MesNews/1.08.03.00-gb
X-Antivirus: avast! (VPS 120226-3, 02/26/2012), Outbound message
X-Face: G"ln~:.wBqHZznO'(lJjjprxGYAjIF7#^u)lx,@"H'F#uXm%j`T6kxat5rq092aW;K*#<!y <6K)wt3HjA)V"XV`W3}Qts*D['Jm:qqpgttEl^wk@9{HJglN-Q'.91Af~ySM>m4jZ(2aW$34N&B&E@ j~tjGV-aC18j1y>zi.\[ZGXsd
Cancel-Lock: sha1:+6QogYgOyOZd8qb8SC2TUFTZhns=
X-ICQ: 543516788
Xref: x330-a1.tempe.blueboxinc.net comp.lang.basic.visual.misc:819

After all the discussion regarding "Dim As New" I see I fell victim to 
one of the issues raised. In my FilterMatches() function I originally 
intended to use separate Collections for 'ItemsToCheck' and 
'UniqueItems' but changed my mind at some point to just reuse 
'ItemsToCheck', but subsequently aboned that notion without correcting 
my code accordingly. I caught this today when using the function even 
though the function seemed to work fine. Here's where I goofed up...

  I declared my collection as follows...
    Dim cItemsToCheck As New Collection

  ..which was my original intent to NOT reuse it.

  After changing my mind to reuse it I used this statement just before
  I added items...

    Set cItemsToCheck = New Collection: On Error Resume Next

  ..which ran no problem, however inappropriate its usage.

I have revised the function to run as originally intended, which was to 
instantiate a different collection for filtering unique items...

Function FilterMatches(Matches As Long, Criteria() As Variant) As 
Boolean
' Compares 2 user-specified cols and filters matches found.
' User can also specific target col to receive resulting list.
' Optionally supports returning a unique list or allow duplicates.
' Optionally supports returning matches or non-matches.
'
' Args In:    Matches: ByRef var to return number of matches found to 
the caller.
'
'             vCriteria(): A variant array containing the filtering 
parameters.
'               Criteria(0) - Address of the values to be filtered
'               Criteria(1) - Address of the values to check
'               Criteria(2) - Label of the column to put the filtered 
list
'               Criteria(3) - Numeric value to determine if we return 
matches or non-matches
'               Criteria(4) - Numeric value to determine if we return a 
unique list or allow dupes
'
' Returns:    True if matches found and no error occurs;
'             False if  a: matches not found --OR-- error occurs;

  Dim i&, j& 'as long
  Dim vFilterRng, vCheckRng, vResult, vaMatches(), vaNoMatches(), 
vaDataOut() 'as variant
  Dim bReturnMatches As Boolean, bMatch As Boolean, bDupesAllowed As 
Boolean
  Dim sMsg$, sRngOut$ 'as string

  'Load the filtering criteria
  vFilterRng = Range(Criteria(0)): vCheckRng = Range(Criteria(1)): 
sRngOut = Criteria(2)
  bReturnMatches = (Criteria(3) = 1): bDupesAllowed = (Criteria(4) = 1)
  ReDim vaMatches(UBound(vFilterRng)): ReDim 
vaNoMatches(UBound(vFilterRng)): j = 0

  'Load the Collection with the values to be checked.
  'Collections only allow unique keys so use OERN (no need to check if 
they already exist)
  Dim cItemsToCheck As New Collection: On Error Resume Next
  For i = LBound(vCheckRng) To UBound(vCheckRng)
    cItemsToCheck.Add key:=CStr(vCheckRng(i, 1)), Item:=vbNullString
  Next 'i
  Err.Clear

Debug.Print Now()
  'Check the Collection for matches
  On Error GoTo MatchFound
  For i = LBound(vFilterRng) To UBound(vFilterRng)
    bMatch = False '..reset
    cItemsToCheck.Add key:=CStr(vFilterRng(i, 1)), Item:=vbNullString
    If bMatch Then
      If bReturnMatches Then vaMatches(j) = vFilterRng(i, 1): j = j + 1
    Else
      vaNoMatches(j) = vFilterRng(i, 1): j = j + 1
      cItemsToCheck.Remove CStr(vFilterRng(i, 1)) '..so dupes of it 
don't get counted
    End If 'bMatch
  Next 'i

  'Initialize the return list
  If bReturnMatches Then vResult = vaMatches Else vResult = vaNoMatches

  'Return a list of unique values?
  If Not bDupesAllowed Then
    On Error GoTo UniqueList
    Dim cUniqueList As New Collection
    For i = LBound(vResult) To UBound(vResult)
      cUniqueList.Add key:=CStr(vResult(i)), Item:=vbNullString
    Next 'i
    ReDim vaDataOut(cUniqueList.Count - 1, 0): j = 0
  Else
    ReDim vaDataOut(UBound(vResult), 0): j = 0
  End If 'Not bDupesAllowed
  Err.Clear: On Error GoTo ErrExit

  'Make the list to return contiguous.
  For i = LBound(vaDataOut) To UBound(vaDataOut)
    If Not vResult(i) = Empty Then vaDataOut(j, 0) = vResult(i): j = j 
+ 1
  Next 'i

  If Matches > 0 Then '..only write if Matches > 0
    Columns(sRngOut).ClearContents
    With Range(sRngOut & "1").Resize(UBound(vaDataOut) + 1, 1)
      .Value = vaDataOut
      .NumberFormat = "0000000000000" '..optional
      .EntireColumn.AutoFit '..optional
    End With
  End If 'Matches > 0
Debug.Print Now()


ErrExit:
'  If bReturnMatches Then Matches = UBound(vResult) ' + 1
  FilterMatches = (Err = 0): Exit Function

MatchFound:
  bMatch = True: Matches = Matches + 1: Resume Next

UniqueList:
  vResult(i) = Empty: Matches = Matches + 1: Resume Next

End Function 'FilterMatches()

-- 
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup!
    comp.lang.basic.visual.misc
    microsoft.public.vb.general.discussion