XL 2016 (RESOLU) Variable Tableau Données colonne en double

[darkjedi]

Bonsoir,

Je suis à la recherche d'une solution pour le problème qui se présente à moi.
J'aimerais vérifier dans 1 colonne définie d'une variable tableau que chaque valeur contenue dans cette colonne ne le soit qu'en double
Voici un début de code mais celui-ci fait ligne 1 avec ligne 2 ensuite ligne 3 avec la ligne 4 mais pas ligne 1 avec l'ensemble des lignes de l'array.
De plus cela ne prend en compte que si le témoin est seul et non s'il est répété plus de 2 fois.
La colonne F est la colonne à vérifier. La colonne J est le résultat attendu de la macro.
Merci pour votre aide.

Voici le bout de code qu'il faut que je développe:

Option Explicit

Dim m As Integer
Dim dernLigneSerie As Long
Dim tabControleSerie() As Variant
Dim controleTemoinSerieDouble As Boolean

Sub VerifTemoinsEnDouble()

    'definition tableau SERIE
    dernLigneSerie = Range("F" & Rows.Count).End(xlUp).Row
    tabControleSerie = Sheets("Feuil1").Range("F2:J" & dernLigneSerie).Value
    
    For m = LBound(tabControleSerie, 1) To UBound(tabControleSerie, 1)
        controleTemoinSerieDouble = False
        If tabControleSerie(m, 1) = tabControleSerie(m + 1, 1) Then
            controleTemoinSerieDouble = True
            m = m + 1
        End If
        
        If controleTemoinSerieDouble = False Then
            tabControleSerie(m, 4) = "témoin seul"
        End If
    Next m
    
    'Transfère les éléments du tableau dans la feuille de calcul
    Sheets("Feuil2").Range("A16").Resize(UBound(tabControleSerie, 1), UBound(tabControleSerie, 2)) = tabControleSerie
    
End Sub

 

[patricktoulon]

Bonjour @patricktoulon ,

Tu payes combien ?

re tu viens de me donner la solution sur un autre post
en gros l’ébauche ça donne ça

Function getLine(F, col1$, col2$, v1, v2)
    derlig = F.Cells(Rows.Count, col1).End(xlUp).Row
    c1 = Cells(1, col1).Resize(derlig).Address(0, 0)
    c2 = Cells(1, col2).Resize(derlig).Address(0, 0)
    For I = 1 To derlig
        a = a + 1
        formule = "=IFERROR(SMALL(IF((" & c1 & "=" & v1 & ")*(" & c2 & "=" & v2 & "),ROW(" & c1 & "))," & a & "),0)"
        x = Evaluate(formule)
        If x <> 0 Then
            Debug.Print formule
            Debug.Print x
        Else
            Exit For
        End If
    Next
End Function
Sub test()
    MsgBox getLine(Feuil1, "A", "B", 1, 1)
End Sub

 

[mapomme]

re @patricktoulon

Bon, tu as trouvé ta solution. Tu me me paieras pas, j'en suis sûr maintenant. Tant pis !

 

[patricktoulon]

me reste a transformer ca en tableau ou tableau d'address et nb d'arguments dynamique

ben non il fallait annoncer le prix d'abords
t'marron dans cette histoire

 

[patricktoulon]

Kado

'*****************************************************************************************************
'recherche multicriteres multicolonnes
'version 2.0
'auteur:patricktoulon(Exceldownload)
'on peut mettre autant de colonnes et d'argument que l'on veut (((à hauteur du len max d'une formule)))
'chaque argument(recherche) correspond a l'item de colonnes du meme index
'basé sur la formule de @mapomme(Exceldownload)
'la récupération des lignes ne concerne que les colonnes demandées
'*****************************************************************************************************
Option Explicit

Sub testx()
    Dim Colonnes, Recherche, Feuille As Worksheet, meslignes
    Colonnes = Array("a", 3, 5)    ' les colonnes peuvent etre exprimées en numerique ou lettre(minuscule ou Majuscule)
    'Recherche = Array(1, 1, 3)    'les arguments peuvent etre string ou numeriques
    Recherche = Array(1, "TOTO", 3)    'les arguments peuvent etre string ou numeriques(Majuscule ou minuscule ne respecte pas la casse)
    Set Feuille = Feuil1 ' feuille concernée
    Set meslignes = GetRangeLine(Feuille, Colonnes, Recherche) 'get
    MsgBox "les ligne trouvées de la plage sont " & vbCrLf & meslignes.Address 'exemple d'utilisation
End Sub
exemple en piece jointe



Function GetRangeLine(F, Colonnes, arg)
    Dim a&, formule$, I&, Fml, Fr$, x, full As Range, res As Range, Derlig&
    Derlig = F.Cells(Rows.Count, Colonnes(0)).End(xlUp).Row
    ReDim Fml(UBound(Colonnes))
    Set full = F.Range(F.Cells(1, Colonnes(0)), F.Cells(Rows.Count, Colonnes(UBound(Colonnes))))
    For I = 0 To UBound(Colonnes)
        Colonnes(I) = F.Name & "!" & F.Cells(1, Colonnes(I)).Resize(Derlig).Address(0, 0)
        If Not IsNumeric(arg(I)) Then arg(I) = """" & arg(I) & """"
        Fml(I) = "(" & Colonnes(I) & "=" & arg(I) & ")"
    Next
    formule = "=IFERROR(SMALL(IF(" & Join(Fml, "*") & " ,ROW(1:" & Derlig & ")),ind),0)"
    For I = 1 To Derlig
        a = a + 1
        Fr = Replace(formule, "ind", a)
        x = Evaluate(Fr)
        If x > 0 Then
            Debug.Print Fr: Debug.Print x
            If res Is Nothing Then Set res = full.Rows(x) Else Set res = Union(res, full.Rows(x))
        Else
            Exit For
        End If
    Next
    Set GetRangeLine = res
End Function

 

[darkjedi]

Bonjour @mapomme @patricktoulon,

Merci à vous pour votre aide. Le code de@mapomme me sert pour mon projet en cours.
Je serais certainement amener à utiliser le code de @patricktoulon dans un autre projet qui arrive.
Ce soir je me coucherais moins bête....