Macro pour importer/fusionner des données

**Dubbleu** · 24/06/2013, 09h35

Bonjour à tous.

j'ai un petit soucis pour faire tourner une macros. j'espère que quelqu'un de plus compétent que moi aura une solution !!

Pour résumer

En feuille1 j'ai un tableau avec données et reférence. sur les feuilles 3 4 et 5 j'ai mes donnée que je voudrais copier dans le tableau de la page 1

en feuille 3 4 5 j'ai un tableau (sur chaque feuille): dans la colonne 1 la reference et dans la colonne 2 les différents produits (plusieurs pour chaque référence)

En gros j'aimerais copier tout les cases associées à une référence (dans les feuille 3 4 5 ) dans une seule case (sur la ligne de la référence) de la feuille 1

Merci d'avance

**Daniel.C** · 24/06/2013, 10h30

Bonjour,

Tu as juste des noms de produit, pas de quantités ou de prix ?

**Dubbleu** · 24/06/2013, 11h44

Bonjour.

Pas de quantité ou de prix non.
juste plusieurs produits associé a chaque numéro de référence. (chacun sur une ligne indépendante dans la colonne 2. Dans la colonne un les cellule sont fusionnées)

si je ne suis pas assez clair je peux envoyer un bout de l'EXCEL

Merci d'avance

**Daniel.C** · 24/06/2013, 12h09

Regarde cette macro et le classeur joint. Sur la feuille Recap, j'ai éliminé les produits doublons.

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
Sub Recap()
    Dim C As Range, Tabl, F As Variant, Plage As Range, Ligne As Long
    F = Array(3, 4, 5)
    With Sheets(1)
        Set Plage = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
    End With
    For i = 0 To 2
        With Sheets(F(i))
            For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
                Ligne = Application.Match(C.Value, Plage, 0)
                If Not IsNumeric(Application.Match(C.Offset(, 1), Sheets(1).Rows(Ligne), 0)) Then
                    Sheets(1).Cells(Ligne, .Columns.Count).End(xlToLeft).Offset(, 1) = _
                        C.Offset(, 1).Value
                End If
            Next C
        End With
    Next i
End Sub

**Dubbleu** · 25/06/2013, 17h24

Merci beaucoup, j'ai bien essayé dans tous les sens mais ca ne veut pas marcher...

**Daniel.C** · 25/06/2013, 17h48

Sur le classeur, les résultats sur la feuille 1. C'est la récapitulation de Feuil3, Feuil4 et Feui5. N'est-ce pas ce que tu attends ? Efface la plage B2:H11 et lance la macro.

**Dubbleu** · 26/06/2013, 10h42

Bonjour, un grand merci pour le temps que vous passez pour m'aider...

c'est assez difficile à expliquer du coup j'ai fait un EXCEL ce sera d'autant plus simple...
Sachant que les produit sont différents sur les pages 3,4 et 5 mais les ref identiques

Cordialement

**Daniel.C** · 26/06/2013, 12h14

Désolé, j'abandonne. Les cellules fusionnées et les macros ne font pas bon ménage. C'est peut être joli, mais ça complique beaucoup (trop) le traitement de quelque chose qui devrait simple.

**Dubbleu** · 27/06/2013, 17h39

Merci quand même

Bonjour, après beaucoup d'essais sans résultat convenable... j'ai pensé à adopter une concacetation...
Mais la encore je suis bloqué...

Du coup pour chaque référence j'aimerais me retrouver avec une seul case contenant tout les produits (avec un retour à la ligne entre chaque idéalement) comme ca ensuite plus de problème de cellules fusionnées !! (meme si ca m'enleve certaines possibilité de tri ce n'est pas génant)

Si vous avez une idée je suis preneur

Salut a tous, salut Daniel... après de longues rechecherche j'ai abandonné les cellules fusionnées

tu avais raison c'est dramatique... du coup je n'ai plus de cellules fusionné. par contre j'ai un soucis avec ta solution...

Parce que du coup comme j'ai fait une concatenation, j'ai "un seul produit" par reférence

Merci d'avance

**Daniel.C** · 27/06/2013, 18h08

Bonjour,

Est-ce que tu peux renvoyer le classeur modifié ?

**Dubbleu** · 27/06/2013, 23h44

Hey,

voila en Pièce jointe un petit bout (tout petit) de mon tableau.
Sur la page 1, dans certaines cases il y a plusieurs référence, toutes les prendre en compte va etre compliqué mais je pourrai les faire manuellement il y en très peu

Merci d'avance

**Daniel.C** · 28/06/2013, 09h46

Merci. Comme il se trouve que je vais avoir un peu de temps aujourd'hui et ce week-end, je vais traiter le classeur avec des cellules fusionnées (à moins que tu ne préfères celui-ci).

**Dubbleu** · 28/06/2013, 10h26

Bonjour

Ah bah si tu pense avoir une solution pour les cellule fusionnées je préfère mais si c'est trop compliqué....

j'ajoute en pièce jointe un excel un peu plus propre avec le format des cellules fusionnées (si ca peut aider...)

Merci d'avance

**Daniel.C** · 29/06/2013, 15h23

Bonjour,

Ça n'a pas été sans mal. J'ai l'impression de ne pas avoir fait au plus simple :

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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub Recap()
    Dim C As Range, F, Dico As Object, Tabl1() As String, Tabl2() As Integer
    Dim Res As String, Txt, Ligne As Long, Ctr As Long
    Set Dico = CreateObject("Scripting.Dictionary")
    Ligne = 1
    With Sheets("Feuil1")
        ReDim Tabl1(Application.CountA(.[E:E]) - 2)
        ReDim Tabl2(Application.CountA(.[E:E]) - 2, 2)
        Ctr = -1
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> "" Then
                Ctr = Ctr + 1
                Tabl1(Ctr) = .Cells(i, 5)
            End If
        Next i
        F = Array("Feuil3", "Feuil4", "Feuil5")
        .[E2:E65000].Clear
        .[R2:T65000].Clear
    End With
    For i = 0 To 2
        With Sheets(F(i))
            For Each C In .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
                If C.Offset(, -1) <> "" Then
                    Res = C.Offset(, -1)
                End If
                If Not Dico.exists(Res & "***" & "***" & i + 1 & "***" & C.Value) Then
                    Dico.Add Res & "***" & i + 1 & "***" & C.Value, Res & "***" & i + 1 & "***" & C.Value
                End If
            Next C
        End With
    Next i
    With Sheets("Feuil1")
        For Each Item In Dico.items
            Txt = Split(Item, "***")
            lig = Application.Match(Txt(0), Tabl1, 0) - 1
            Tabl2(lig, CInt(Txt(1)) - 1) = Tabl2(lig, CInt(Txt(1)) - 1) + 1
        Next Item
        For i = 0 To UBound(Tabl1)
            'Ligne = Ligne + 1
            lig = 0
            For x = 0 To UBound(Tabl2, 2)
                If Tabl2(i, x) > lig Then lig = Tabl2(i, x)
            Next x
            For x = 1 To lig
                Ligne = Ligne + 1
                .Cells(Ligne, 5) = Tabl1(i)
            Next x
        Next i
        For Each Item In Dico.items
            For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
                Txt = Split(Item, "***")
                If .Cells(i, 5) = Txt(0) And .Cells(i, 17).Offset(, CInt(Txt(1))) = "" Then
                    .Cells(i, 17).Offset(, CInt(Txt(1))) = Txt(2)
                    Exit For
                End If
            Next i
        Next Item
        With .[E1].CurrentRegion
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        With .[E1].CurrentRegion.Offset(, 13).Resize(, 3)
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        Res = "E2"
        Application.DisplayAlerts = False
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> .Range(Res) Then
                .Range(.Cells(i, 5).Offset(-1), Range(Res)).Merge
                Res = .Cells(i, 5).Address
            End If
        Next i
        .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)).VerticalAlignment = xlCenter
        Application.DisplayAlerts = True
    End With
End Sub

**Dubbleu** · 01/07/2013, 09h42

Bonjour Daniel !

Merci beaucoup, cependant lorsque je compile, j'ai une erreur qui s'affiche pour cette ligne

Erreur d'éxecution 457, cette clé est déjà associée à un élement de cette collection

Code :

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

 Dico.Add Res & "***" & I + 1 & "***" & C.Value, Res & "***" & I + 1 & "***" & C.Value

J'ai pourtant bien regardé et je ne comprends pas pourquoi cette erreur s'affiche...

**Daniel.C** · 01/07/2013, 09h48

Bonjour,

Moi non plus. Est-ce que tu as cette erreur avec le classeur que tu m'as fourni ?

**Dubbleu** · 01/07/2013, 10h03

Non justement... c'est pour ca que je comprends encore moins...

**Daniel.C** · 01/07/2013, 10h46

Je te joins le fichier. J'ai fait une modif pour que les cellules de la dernière référence soient fusionnées. Lance la macro Recap :

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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub Recap()
    Dim C As Range, F, Dico As Object, Tabl1() As String, Tabl2() As Integer
    Dim Res As String, Txt, Ligne As Long, Ctr As Long
    Set Dico = CreateObject("Scripting.Dictionary")
    Ligne = 1
    With Sheets("Feuil1")
        ReDim Tabl1(Application.CountA(.[E:E]) - 2)
        ReDim Tabl2(Application.CountA(.[E:E]) - 2, 2)
        Ctr = -1
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> "" Then
                Ctr = Ctr + 1
                Tabl1(Ctr) = .Cells(i, 5)
            End If
        Next i
        F = Array("Feuil3", "Feuil4", "Feuil5")
        .[E2:E65000].Clear
        .[R2:T65000].Clear
    End With
    For i = 0 To 2
        With Sheets(F(i))
            For Each C In .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
                If C.Offset(, -1) <> "" Then
                    Res = C.Offset(, -1)
                End If
                If Not Dico.exists(Res & "***" & "***" & i + 1 & "***" & C.Value) Then
                    Dico.Add Res & "***" & i + 1 & "***" & C.Value, Res & "***" & i + 1 & "***" & C.Value
                End If
            Next C
        End With
    Next i
    With Sheets("Feuil1")
        For Each Item In Dico.items
            Txt = Split(Item, "***")
            lig = Application.Match(Txt(0), Tabl1, 0) - 1
            Tabl2(lig, CInt(Txt(1)) - 1) = Tabl2(lig, CInt(Txt(1)) - 1) + 1
        Next Item
        For i = 0 To UBound(Tabl1)
            lig = 0
            For x = 0 To UBound(Tabl2, 2)
                If Tabl2(i, x) > lig Then lig = Tabl2(i, x)
            Next x
            For x = 1 To lig
                Ligne = Ligne + 1
                .Cells(Ligne, 5) = Tabl1(i)
            Next x
        Next i
        For Each Item In Dico.items
            For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
                Txt = Split(Item, "***")
                If .Cells(i, 5) = Txt(0) And .Cells(i, 17).Offset(, CInt(Txt(1))) = "" Then
                    .Cells(i, 17).Offset(, CInt(Txt(1))) = Txt(2)
                    Exit For
                End If
            Next i
        Next Item
        With .[E1].CurrentRegion
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        With .[E1].CurrentRegion.Offset(, 13).Resize(, 3)
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        Res = "E2"
        Application.DisplayAlerts = False
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> .Range(Res) Then
                .Range(.Cells(i, 5).Offset(-1), Range(Res)).Merge
                Res = .Cells(i, 5).Address
            End If
            If i = .Cells(.Rows.Count, 5).End(xlUp).Row Then
                .Range(.Cells(i, 5), Range(Res)).Merge
            End If
        Next i
        .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)).VerticalAlignment = xlCenter
        Application.DisplayAlerts = True
    End With
End Sub

**Dubbleu** · 01/07/2013, 15h18

Voila un EXCEL avec le bug qui s'affiche....

**Daniel.C** · 01/07/2013, 16h13

Je viens de faire tourner la macro sur le nouveau classeur sans bug. Par contre et contrairement au classeur initial, les cellules de la colonne B des feuilles 3, 4 et 5 sont fusionnées.

Macro pour importer/fusionner des données

Macros et VBA Excel

Discussions similaires

Partager

Partager