copier cellules

[jlppap]

Bonjour,
mes connaissances en vba étant très limitées, je pose donc la question.
sous excel 2003
j'ai un fichier avec plusieurs colonnes A (article) à G contenant des données et dans la colonne H d'autres données liées au même article (col. A),mais il est possible qu'il y ait plusieurs lignes pour ce même art.

mon problème est le suivant; comment faire pour mettre ces données (col.H) sur une même ligne, à partir de la colonne I,J,etc, et donc ne garder qu'une ligne par artgicle et supprimer les autres lignes devenues inutiles?

Pas très clair, je m'en excuse... j'ai joint un petit fichier pour mieux comprendre.

MERCI d'avance pour votre aide.

 

[Pyrof]

Re : copier cellules

bonjour

Voila un bout de code :

Sub test()
Dim tab_art
Set tab_art = CreateObject("Scripting.dictionary")
l = 2
c = 4
'----------------------------------------------------------
'           lecture des données
'----------------------------------------------------------
While Cells(l, c) <> ""
    If Cells(l, 1) <> "" Then
        cle = Cells(l, 1)
        data = Cells(l, 2) & "," & Cells(l, 3) & "," & Cells(l, 4)
        tab_art(cle) = data
    Else
        tmp = tab_art(cle)
        tmp = tmp & "," & Cells(l, 4)
        tab_art(cle) = tmp
    End If
    l = l + 1
Wend
    
'----------------------------------------------------------
'           ecriture des données
'----------------------------------------------------------
l = 16
For Each cle In tab_art
    l = l + 1
    Cells(l, 1) = cle
    tmp = tab_art(cle)
    tmp2 = Split(tmp, ",")
    For b = 0 To UBound(tmp2)
        Cells(l, 2 + b) = tmp2(b)
    Next
Next

End Sub

 

[Robert]

Re : copier cellules

Bonjour Jlppap, Pyrof, bonjour le forum,

Pyrof a encore un code qui tue !!! Je me permets quand même de t'envoyer ma proposition plus archaïque en pièce jointe.

Le code est beaucoup plus long à cause, principalement, de la mise en forme mais il est loin d'avoir l'efficacité de celui de Pyrof:

Sub Macro2()
Dim x As Integer 'déclare la variable x
Dim li As Integer 'déclare la variable li (LIgne)
Dim dest As Range 'déclare la variable dest (DESTination)
Dim col As Byte 'décalre la variable col (COLonne)
Dim lf As Integer 'décalre la variable lf (Ligne de Fin)
 
'alignement des "détails"
lf = Range("D65536").End(xlUp).Row 'définit la variable lf
For x = 2 To lf 'boucle 1 sur toutes les cellules de la colonne A (en partant de la deuxième ligne)
    If Cells(x, 1).Value = "" Then 'condition : si la cellule est vide
        li = Cells(x, 1).End(xlUp).Row 'définit la variable li
        Set dest = Cells(li, 256).End(xlToLeft).Offset(0, 1) 'définit la variable dest
        Cells(x, 1).Offset(0, 3).Cut dest 'coupe le detail et le colle dans dest
    End If 'fin de la condition
Next x 'prochaine cellule de la boucle
 
'suppression des lignes vides
For x = lf To 2 Step -1 'boucle 2 inversée sur toutes les cellules de la colonne A
    If Cells(x, 1).Value = "" Then Rows(x).Delete 'si la cellule est vide, supprime la ligne
Next x 'prochaine cellule de la boucle
 
'mise en forme
col = Range("A1").CurrentRegion.Columns.Count 'définit la variable col
'rajoute "détail 2", "détail 3", etc.
For x = 5 To col
    Cells(1, x).Value = "détail " & x - 3
    Cells(1, x).Font.Bold = True
    Cells(1, x).Interior.ColorIndex = Cells(1, x - 1).Interior.ColorIndex
Next x
'bordures (contour)
With Range("A1").CurrentRegion
    'suppresion
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    'ajout
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
End With
'bordure première ligne
With Range("A1").CurrentRegion.Resize(2)
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End Sub

 

[jp14]

Re : copier cellules

Bonjour le fil

Ci joint un fichier avec une autre approche.
L'utilisateur doit indiquer le tableau à copier et la cellule de destination.

A tester

JP

 

[jlppap]

Re : copier cellules

MERCI beaucoup à tous.

Pour Pyrof, c'est parfait.
pour les autres, je n'ai pas encore testé mais à l'avance...

MERCI à vous tous.