Eliminer répitition valeur dans cellule VBA

Question

Bonjour, 

Je suis débutant en VBA et j'ai un problème qui m'enquiquine sérieusement parce qu'il m'empêche d'avancer dans mon travail ... Je vous serais très reconnaissant si vous pouviez me venir en aide ...
Voilà mon problème :
J'ai deux colonnes "A" et "B" dont les infos sont liées.
Dans les cellules de "A" j'ai répétition des infos séparées par un ";" du style maison;maison;maison etc le nombre de répétition est indéterminée. 
Dans la colonne "B" j'ai aussi répitions d'infos mais celles ci peuvent être différentes du style
robinet;robinet;évier;garage;garage etc le nombre de répétition est aussi indéterminée. 
Ce que je souhaiterais c'est d'avoir création de lignes qui gardent les infos dans les autres colonnes ("C","D" etc) qui elles sont uniques mais cette fois avec dans "A" la valeur maison et une ligne pour chaque valeur différente dans "B". Dans cet exemple ça ferait:

Colonne A               Colonne B
maison                   robinet
maison                   évier
maison                   garage

Je vous remercie d'avance car le problème me paraît compliqué.

A bientôt

Anthony 



Configuration: Windows 7 / Firefox 4.0.1

Normad · Answer

Oui, ce n'est pas super-simple (plus de 2 heures...) 
Avec les données dans les colonnes A et B de Feuil1 :


Sub Traitement()
    Dim TableauB() As String, ValeurA As String, I As Integer, Y As Integer, Z As Integer, Ligne As Long
    Ligne = 1
    For I = 1 To Sheets("Feuil1").Range("A1").End(xlDown).Row
        ValeurA = TableauValeurs(Sheets("Feuil1").Range("A" & I).Value, True)
        TableauB = TableauValeurs(Sheets("Feuil1").Range("B" & I).Value)
        Z = 1
        For Y = Ligne To UBound(TableauB) + Ligne - 1
            Sheets("Feuil1").Range("C" & Y).Value = ValeurA
            Sheets("Feuil1").Range("D" & Y).Value = TableauB(Z)
            Z = Z + 1
        Next Y
        Ligne = Y
    Next I
End Sub

Function TableauValeurs(strTest As String, Optional A As Boolean)
    Dim Y As Integer, I As Integer, Decomp() As String, Test As String
    Test = strTest
    Y = InStr(1, Test, ";")
    While Y > 0
        I = I + 1
        ReDim Preserve Decomp(I)
        Decomp(I) = Left(Test, Y - 1)
        If A Then GoTo Val1
        Test = Mid(Test, Y + 1)
        Y = InStr(1, Test, ";")
    Wend
    I = I + 1
    ReDim Preserve Decomp(I)
    Decomp(I) = Mid(Test, Y + 1)
    
    TableauValeurs = SupprDoublons(Decomp)
    Exit Function
Val1:
    TableauValeurs = Decomp(1)
End Function

Function SupprDoublons(Tableau)
    Dim I As Integer, Y As Integer, NewTab() As String, Cpte As Integer, Ajoute As Boolean
    If Not IsArray(Tableau) Then
        SupprDoublons = Tableau
        Exit Function
    End If
    
    For I = 1 To UBound(Tableau)
        For Y = 1 To IIf(TailleTab(NewTab) = 0, 1, Cpte)
            If TailleTab(NewTab) = 0 Then
                Ajoute = True
            Else
                If Tableau(I) <> NewTab(Y) Then
                    Ajoute = True
                Else
                    Ajoute = False
                End If
            End If
        Next Y
        If Ajoute Then
            Cpte = Cpte + 1
            ReDim Preserve NewTab(Cpte)
            NewTab(Cpte) = Tableau(I)
        End If
    Next I
    SupprDoublons = NewTab
End Function

Private Function TailleTab(Tableau() As String) As Integer
    On Error GoTo vide
    TailleTab = UBound(Tableau)
    Exit Function
vide:
    TailleTab = 0
End Function

Eliminer répitition valeur dans cellule VBA

1 réponse

Votre réponse

Discussions similaires

Newsletters