Array met variabele grootte vullen met slechts 1 waarde geeft foutmelding

[remember]

Beste helpers,

In een macro die duizenden rijen moet afwerken, moeten we eerst controleren of waarden uit één kolom van een werkblad voorkomen in een kolom van een ander werkblad. In plaats van telkens terug te gaan naar het werkblad met de kolom waarmee we willen vergelijken, vullen we een array met alle voorkomende unieke waarden uit de kolom van het werkblad waarmee we willen vergelijken. Hierdoor kunnen we de snelheid van de macro deftig verhogen. Enkel indien een waarde voorkomt in de array gaan we verder met de macro

Het aantal unieke waarden waarmee we vergelijken, kan variëren van 1 tot 9. Het aantal posities in de array is dus variabel.

Alles gaat goed behalve indien er slechts één unieke waarde is om de array te vullen dan krijgen we een fout 9 tijdens het uitvoeren "het subscript valt buiten het bereik".
We hebben dit nu opgelost door de code te aan te passen en een voorwaarde in te bouwen indien er maar 1 waarde in de array voorkomt.
Dit werkt wel maar we vragen ons af of er geen elegantere (kortere en rechtlijnige) oplossing is om tot hetzelfde resultaat te komen.

Hieronder het stukje code om de array te vullen en aansluitend het aantal waarden in de array te tellen (die telling is onder meer nodig om nadien de beschreven fout te kunnen omzeilen).

   Dim shName1 As String
   Dim shName2 As String
   Dim shName3 As String
   Dim LastRow As Long
   Dim LastCol As Long

        shName1 = "alfa"
        shName2 = "beta"
        shName3 = "gamma"
        LastRow = ActiveSheet.UsedRange.rows(ActiveSheet.UsedRange.rows.Count).Row

    rng = Range("'" & shName2 & "'!V2:V" & LastRow)
    With CreateObject("System.Collections.ArrayList")
        For Each it In rng
        If it <> "" And Not .contains(it) Then .Add it
        Next
        
        .Sort

        MyArray = Application.Transpose(.toarray())
        vAantal = .Count
    End With

En hieronder de code om waarden uit een kolom van een ander werkblad te vergelijken met de waarden in de array.
Het eerste stukje is erbij gekomen om de fout te omzeilen wanneer de array slechts 1 waarde bevat. Daarvoor zoeken we dus een elegantere oplossing.

    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2
        
    If vAantal = 1 Then
        color = RGB(255, 192, 0)        'oranje (49407)

        If MyArray(1) = "FVA" Then
            GoTo FVA
        ElseIf MyArray(1) = "OZI" Then
            GoTo OZI
        Else: GoTo OTHER
        End If
    End If
        
    For i = 1 To UBound(MyArray)
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2
        
        If MyArray(i, 1) = "FLA" Then
            color = RGB(255, 255, 0)        'geel (65535)
        ElseIf MyArray(i, 1) = "FCH" Then
            color = RGB(255, 0, 0)           'rood
        ElseIf MyArray(i, 1) = "FME" Then
            color = RGB(146, 208, 80)      'groen (5296274)
        ElseIf MyArray(i, 1) = "FPA" Then
            color = RGB(0, 176, 80)         'donkergroen
        ElseIf MyArray(i, 1) = "FTI" Then
            color = RGB(0, 176, 240)       'hemelsblauw (15773696)
        ElseIf MyArray(i, 1) = "FGR" Then
            color = RGB(0, 112, 192)       'blauw
        ElseIf MyArray(i, 1) = "FVA" Then
            color = RGB(255, 192, 0)       'oranje (49407)
        ElseIf MyArray(i, 1) = "OZI" Then
            color = 5287936
        End If

        If MyArray(i, 1) = "FVA" Then
            GoTo FVA
        ElseIf MyArray(i, 1) = "OZI" Then
            GoTo OZI
        Else: GoTo OTHER
        End If

Dank bij voorbaat voor eventuele suggesties.

Paul

 

[snb]

sub M_snb()
   ActiveSheet.UsedRange.columns(22).advancedfilter 2,,ActiveSheet.cells(1,200),true
   c00="|" & join(application.transpose(ActiveSheet.cells(1,200).currentregion),"|") & "|"                       '   lijst met unieke waarden
   
   sn=sheet2.usedrange.rows(sheet2.usedrange.columns.count)
   for j=1 to ubound(sn)
     if instr(c00,"|" & sn(j,1) & "|") then ......
   next
End Sub

 

[remember]

sub M_snb()
   ActiveSheet.UsedRange.columns(22).advancedfilter 2,,ActiveSheet.cells(1,200),true
   c00="|" & join(application.transpose(ActiveSheet.cells(1,200)),"|") & "|"                       '   lijst met unieke waarden
   
   sn=sheet2.usedrange.rows(sheet2.usedrange.columns.count)
   for j=1 to ubound(sn)
     if instr(c00,"|" & sn(j,1) & "|") then ......
   next
End Sub

Bedankt voor de snelle reactie. De 2de lijn code die begint met "c00=" na het maken van de lijst met unieke waarde in kolom 200 (GR) genereert een fout "typen komen niet met elkaar overeen".

Aangezien ik een beginner ben in VBA, nog enkele vermoedelijk domme vragen.

1. Als ik de rest van de code goed begrijp, wordt er nu vergeleken met het lijstje met unieke waarden dat is opgebouwd in werkblad 1. Verlies je zo niet opnieuw het voordeel van een array waarbij het systeem de lijst met toegelaten waarden in zijn werkgeheugen houdt? De uit te mesten lijsten zijn bijna 20.000 rijen lang
2. Waarvoor wordt "|" gebruikt voor en na de celverwijzing ?

Met vriendelijke groeten
Paul

 

[OctaFish]

In je oorspronkelijke code werk je met een vaste onderwaarde voor de matrix:

For i = 1 To UBound(MyArray)

Dat werkt alleen als je Option Base 1 gebruikt, anders is de onderwaarde wellicht 0. En dan klopt je functie natuurlijk niet. Je zou dus beter zo kunnen werken:

For i = LBound(MyArray) To UBound(MyArray)

Dan heb je dat probleem niet.

 

[snb]

Ik heb de code aangepast in mijn vorige bericht.

 

[remember]

Beste helpers.

De oplossing van SNB blijft een fout "typen komen niet met elkaar overeen" geven.
Onze voorkeur ging uit naar de oplossing van OctaFish omdat we vermoeden dat het gebruik van een array, de snelheid zal verhogen.
We pasten onze oorspronkelijke code hierboven aan met de gegeven suggestie. We wijzigden de code met de vaste ondergrens 1 naar Lbound(MyArray)
Toch blijven we hetzelfde probleem behouden. Wanneer er slechts één unieke waarde voorkomt in de array waarmee we onze gegevens vergelijken, krijgen we nog steeds een fout 9 "het subscript valt buiten het bereik".

De macro doet dus wel wat er verwacht wordt en we kunnen er mee verder, maar de code blijft volgens ons te omslachtig.
Het is geen probleem om veel tijd in te steken maar we hoopten te doorgronden wat de oorzaak is omdat er op meerdere plaatsen in de macro wordt teruggegrepen naar die Array om waarden te vergelijken en we nu telkens in 2 stappen moeten werken.

Hieronder de huidige code zoals we ze nu gebruiken om de array op te bouwen met unieke waarden uit het ene werkblad.

   Dim shName1 As String
   Dim shName2 As String
   Dim shName3 As String
   Dim LastRow As Long
   Dim LastCol As Long

        shName1 = "alfa"
        shName2 = "beta"
        shName3 = "gamma"
        LastRow = ActiveSheet.UsedRange.rows(ActiveSheet.UsedRange.rows.Count).Row

    rng = Range("'" & shName2 & "'!V2:V" & LastRow)
    With CreateObject("System.Collections.ArrayList")
        For Each it In rng
        If it <> "" And Not .contains(it) Then .Add it
        Next
        
        .Sort

        MyArray = Application.Transpose(.toarray())
        vAantal = .Count
    End With

En de huidige code in het volgende werkblad om waarden te vergelijken met de array.

' loop doorheen de array met hotels
' out of range fout indien slechts 1 hotel in array daarom in 2 stappen

    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2
        
    If vAantal = 1 Then
        color = RGB(255, 192, 0)        'oranje (49407)

        If MyArray(1) = "FVA" Then
            GoTo FVA
        ElseIf MyArray(1) = "OZI" Then
            GoTo OZI
        Else: GoTo HOTEL
        End If
    End If
    
    For i = LBound(MyArray) To UBound(MyArray)
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2
        
        If MyArray(i, 1) = "FLA" Then
            color = RGB(255, 255, 0)        'geel (65535)
        ElseIf MyArray(i, 1) = "FCH" Then
            color = RGB(255, 0, 0)          'rood
        ElseIf MyArray(i, 1) = "FME" Then
            color = RGB(146, 208, 80)       'groen (5296274)
        ElseIf MyArray(i, 1) = "FPA" Then
            color = RGB(0, 176, 80)         'donkergroen
        ElseIf MyArray(i, 1) = "FTI" Then
            color = RGB(0, 176, 240)        'hemelsblauw (15773696)
        ElseIf MyArray(i, 1) = "FGR" Then
            color = RGB(0, 112, 192)        'blauw
        ElseIf MyArray(i, 1) = "FVA" Then
            color = RGB(255, 192, 0)        'oranje (49407)
        ElseIf MyArray(i, 1) = "OZI" Then
            color = 5287936
        End If
        
        If MyArray(i, 1) = "FVA" Then
            GoTo FVA
        ElseIf MyArray(i, 1) = "OZI" Then
            GoTo OZI
        Else: GoTo HOTEL
        End If

Met vriendelijke groeten

Paul

 

[snb]

sub M_snb()
   On error resume next
   ActiveSheet.UsedRange.columns(22).advancedfilter 2,,ActiveSheet.cells(1,200),true
   c00="|" & join(application.transpose(ActiveSheet.cells(1,200).currentregion),"|") & "|"    '   lijst met unieke waarden
   if err.number<>0 then c00= "|" & ActiveSheet.cells(1,200) & "|"         ' als de 'lijst' slechts 1 cel bevat

   sn=sheet2.usedrange.rows(sheet2.usedrange.columns.count)
   for j=1 to ubound(sn)
     if instr(c00,"|" & sn(j,1) & "|") then ......
   next
End Sub

Vergelijken in een string gaat veel sneller dan in een array.

 

[remember]

Hartelijk dank,
Gaat inderdaad sneller zo.

Bedankt
Paul