Dispatch ou # de concatenation des valeurs

Version imprimable

2 pièce(s) jointe(s)

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:

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 :

Citation:

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

Ca se produit à la ligne de code suivante

Code:

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:

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

09/01/2014, 18h46
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 …

dispatch

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:

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,

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:

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!

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:

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 :plusser: si ce message aide …

__________________________________________________________________________________________
Ne pas confondre faux départ et paravent !