Discussion :

[rayba89]

Bonjour,

Je pars d'un fichier excel avec plusieurs identifiants (prenon par exemple)
pour chaque identifiant j'ai plusieurs attributs.
Trois de ces attributs contiennent des termes delimités par des ";"
Mon besoin est de créer une ligne pour chaque terme dans ces attributs et effacer touts les autres termes dans les 3 attributs en question.
en pj un exemple qui montre le resultat attendu.

j'ai developpé un premier code (qui n'est pas complet mais j'aimerais voir ce que ca donne) mais ca ne marche pas!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Option Explicit
 
Private Sub CommandButton1_Click()
Dim monDict
Dim SP_A$()
Dim SP_B$()
Dim SP_C$()
Set monDict = CreateObject("Scripting.dictionary")
Dim nbre As Variant
Dim aux
Dim i
 
With ThisWorkbook.Worksheets(1)
For Each nbre In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp))
If Not monDict.Exists(CStr(nbre.Value)) Then
    monDict.Add CStr(nbre.Value), CStr(nbre.Row)
End If
Next nbre
End With
 
 
Dim cle
 
For Each cle In monDict.Keys
aux = monDict.Item(cle)
SP_A = Split(Cells(aux, 5), ";")
SP_B = Split(Cells(aux, 6), ";")
SP_C = Split(Cells(aux, 7), ";")
For i = 0 To UBound(SP_A)
Cells(aux, 1).Select
ActiveCell.Offset(1).EntireRow.Insert
Cells(aux, 1).Select
ActiveCell.EntireRow.Copy Cells(aux + 1, 1)
Cells(aux+i , 6).Select
Selection.ClearContents
Cells(aux+i , 7).Select
Selection.ClearContents
Next i
Next cle
End Sub

ca m'envoie le message d'erreur suivant :

erreur d'exécution '1004'
erreur definie par l'application ou par l'objet

Ca se produit à la ligne de code suivante

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For Each nbre In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp))

Je voulais reproduire le meme code pour "SP_B" et "SP_C" mais je la je bloque au tout debut.

Je pensais faire aussi l'algo suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
UBound_tot = UBound(SP_A) + UBound(SP_C) + UBound(SP_C)
for i=0 to UBound_tot
'insert new row
'if i<UBound(SP_A)  donc cell(aux,6) <- SP_A(i)
'if UBound(SP_A) < i < UBound(SP_A) + UBound(SP_B) 
'donc cell(aux,7) <- SP_B(i)
'if UBound(SP_A) + UBound(SP_B) < i < UBound_tot
'donc cell(aux,8) <- SP_C(i)

quelqu'un aura une meilleure idée?
en pj la macro (feuille 2)

Merci d'avance pour votre aide

[Marc-L]

Bonjour, bonjour,

déjà il va falloir homogénéiser le séparateur car j'en vois plus d'un !

Ensuite il faudrait préciser la destination …

Enfin, je ne comprends pas l'utilisation d'un dictionnaire, un simple Split suffit à séparer les données …

[nibledispo]

Bonjour,

Indépendamment de l'erreur annoncé ta sélection ne prenait pas la dernière ligne en compte.
Par ailleurs tout le traitement qui suit ne pouvait donner un résultat.

Regarde ce code qui traite directement le fichier sans passer par le dico et restitue un résultat plus condensé que celui demandé.
On peut si ton fichier est conséquent envisager à la limite de passer par une variable tableau mais surement pas un dico comme le souligne Marc.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
 
Private Sub CommandButton1_Click()
Dim monDict
Dim SP_A$()
Dim SP_B$()
Dim SP_C$()
Dim i As Integer, derlig As Integer, lig As Integer, nombre As Integer
Dim plage As Range
Dim cel As Object
 
derlig = Sheets(1).Range("A65536").End(xlUp).Row
Set plage = Range("A2:A" & derlig)
lig = 5
 
For Each cel In plage
    SP_A = Split(Cells(cel.Row, 5), ";")
    SP_B = Split(Cells(cel.Row, 6), ";")
    SP_C = Split(Cells(cel.Row, 7), ";")
    nombre = Application.Max(UBound(SP_A, 1), UBound(SP_B, 1), UBound(SP_C, 1))
    For i = 0 To nombre
        On Error Resume Next
        Rows(cel.Row).Copy Rows(derlig + lig)
        Range(Cells(derlig + lig, 5), Cells(derlig + lig, 7)).ClearContents
        Cells(derlig + lig, 5) = SP_A(i)
        Cells(derlig + lig, 6) = SP_B(i)
        Cells(derlig + lig, 7) = SP_C(i)
        lig = lig + 1
    Next i
Next cel
End Sub

Cordialement,

[rayba89]

Bonjour nibledispo, Marc-L, toujours la pour m'aider!

@ Marc-L : Ma destination sera une nouvelle feuille excel, sauf que je voulais trouver l'algo qui marche tout d'abord, j'ai fais sans dictionnaire finalement.

@ nibledispo : ton code ne repondait pas tout a fait a mon besoin, je veux créer une ligne pour chaque attribut (que ca soit en europe, Asie, ou Amerique dans l'exemple).
Mais je me suis basé sur ton code pour trouver la solution
j'ai appliqué l'algo que j'avais indiqué hier, voila le code final:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Dim SP_C$()
Dim i As Integer, derlig As Integer, lig As Integer, nombre As Integer
Dim plage As Range
Dim cel As Object
 
derlig = Sheets(1).Range("A65536").End(xlUp).Row
Set plage = Range("A2:A" & derlig)
lig = 5
 
For Each cel In plage
    SP_A = Split(Cells(cel.Row, 5), ";")
    SP_B = Split(Cells(cel.Row, 6), ";")
    SP_C = Split(Cells(cel.Row, 7), ";")
    'nombre = Application.Max(UBound(SP_A, 1), UBound(SP_B, 1), UBound(SP_C, 1))
    'nombre = Application.Sum(UBound(SP_A, 1), UBound(SP_B, 1), UBound(SP_C, 1))
    nombre = UBound(SP_A, 1) + UBound(SP_B, 1) + UBound(SP_C, 1) + 2
    For i = 0 To nombre
        On Error Resume Next
        Rows(cel.Row).Copy Rows(derlig + lig)
        Range(Cells(derlig + lig, 5), Cells(derlig + lig, 7)).ClearContents
        Cells(derlig + lig, 5) = SP_A(i)
        If (i >= UBound(SP_A, 1) + 1) And (i < UBound(SP_A, 1) + UBound(SP_B, 1) + 2) Then
        Range(Cells(derlig + lig, 5), Cells(derlig + lig, 7)).ClearContents
        aux1 = i - (UBound(SP_A, 1) + 1)
        Cells(derlig + lig, 6) = SP_B(aux1)
        End If
        If (i >= UBound(SP_A, 1) + UBound(SP_B, 1) + 2) Then
        Range(Cells(derlig + lig, 5), Cells(derlig + lig, 6)).ClearContents
        aux2 = i - (UBound(SP_A, 1) + UBound(SP_B, 1) + 2)
        Cells(derlig + lig, 7) = SP_C(aux2)
        End If
        lig = lig + 1
    Next i
Next cel

Pas sure que ca soit la meilleure methode mais ca marche parfaitement!

Merci à vous deux!

[Marc-L]

Le dictionnaire est utile pour éviter les doublons …

Voie de la facilité avec la ligne n°18 et si elle s'avère vraiment utile, le code n'est alors pas tip top …


Voici un exemple traitant le tableau source en Feuil2 vers la Feuil3, code à insérer dans le module de la Feuil2 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Demo()
    Application.ScreenUpdating = False
    Feuil3.UsedRange.Clear
 
    With [A1].CurrentRegion
        CC& = .Columns.Count:  If CC < 5 Then Beep: End
        .Rows(1).Copy Feuil3.[A1]
        L& = 1
 
        For R& = 2 To .Rows.Count
            C4 = .Cells(R, 1).Resize(, 4).Value
 
            For C& = 5 To CC
                For Each V In Split(.Cells(R, C).Value, ";")
                    L = L + 1
                    Feuil3.Cells(L, 1).Resize(, 4).Value = C4
                                Feuil3.Cells(L, C).Value = Trim(V)
                Next V
            Next C
        Next R
    End With
 
    Feuil3.Activate
    Application.ScreenUpdating = True
    End
End Sub

Lorsque les données d'une plage à traiter sont contigües, priorité à la propriété CurrentRegion !

S'il y a beaucoup de lignes à traiter, l'utilisation de variables tableau rendra plus rapide l'exécution du code …

__________________________________________________________________________________________

Merci de cliquer sur si ce message aide …

__________________________________________________________________________________________
Ne pas confondre faux départ et paravent !