XL 2019 Copier-coller tableau dans une feuille de calcul via VBA

[66alex66]

Bonsoir tout le monde,

Pourriez-vous m'aider à solutionner la problématique suivante ?

J'ai ce tableau :

Ce tableau se trouve sur la feuille de calcul nommée "Fusion BH" dans mon fichier annexé.
J'aimerais, en cliquant sur le bouton "coller tableau", que les données se trouvant dans les colonnes A : Dse copie-colle (sur le tableau de la feuille de calcul "tableau") parallèlement à l'EAN indiqué dans la cellule U5.

Résultat que j'aimerais obtenir :

En cliquant sur le bouton "coller tableau" j'aimerais que, via une formule VBA, les données des colonnes A : D se "copient-collent" au niveau de l'EAN que j'aurai choisi en U5.

Pour donner ce résultat :

La formule devrait se dire "étant donné que U5 indique "1" (de la feuille de calcul "Fusion BH"), je copie-colle le tableau en J11 (de la feuille de calcul "Tableau" au niveau du premier EAN détecté (colonne A).
Si j'avais indiqué "2" en U5 le tableau se copie-collerait en J40 puisque je lui demanderai de se relier au deuxième EAN du tableau"
Et ainsi de suite sans avoir de "limite" d'EAN.

Un tout grand merci pour votre aide précieuse !

 

[Phil69970]

Bonjour @66alex66

Quelques remarques en passant

47 modules de 4 ou 5 lignes et au moins 10 modules vides
2 module de classe vide
4 USF qui ne servent à rien

Bref c'est parfait pour rebuter la plupart des contributeurs du site

Je te conseillerais de faire le ménage et de regrouper les sub

Une piste par exemple :
Un module pour les actions (copie de A vers B par exemple)
Un module pour les suppressions
Un module pour les messages
Un module pour les fonctions
Etc
Au total tu auras 5 ou 6 modules
Bien sur une autre méthode est possible suivant tes gouts

De plus certaines sub pourrait certainement être regrouper en 1 seule sub avec des tests conditionnels
etc....

Bonne lecture

@Phil69970

 

[Ruku.G49]

Bonjour ,Pour "En cliquant sur le bouton "coller tableau" j'aimerais que, via une formule VBA, les données des colonnes A : D se "copient-collent" au niveau de l'EAN que j'aurai choisi en U5."
Dans la partie développeur vous pouvez faire enregistrer une macro. vous faite se que vous aimeriez obtenir manuellement et cela enregistrera les modalité de fonctionnement et il y aura plus qu'a l'intégré la macro a votre bouton "coller tableau"

 

[job75]

Bonjour,

A priori dans la feuille "TABLEAU" on peut utiliser pour coller :

- en J11=> 29 lignes

- en J40 => 24 lignes

- en J64 => 11 lignes

- en J75 => 11 lignes.

Merci de préciser ce qu'il faut faire quand le tableau à coller dépasse ces nombres de lignes.

A+

 

[66alex66]

Merci à tous pour vos suggestions.

@job75 Si possible lorsque le tableau à coller dépasse le nombre de lignes, j'aimerais que des lignes supplémentaires s'ajoutent pour que le tableau se colle correctement en laissant un espace de deux lignes avant l'EAN suivant.

Exemple en J64 où il n'y avait, au départ, que 11 lignes.

 

[job75]

Voyez le fichier joint et la macro du bouton dans Module1 :

Sub Coller_Tableau()
Dim P As Range, nlig&, nref&, ean&, i&, n&, j&, ajout&
With Sheets("Fusion BH")
    Set P = .[A1].CurrentRegion.Resize(, 4)
    nlig = P.Rows.Count
    nref = Int(Val(CStr(.[U5])))
    If nref < 1 Then nref = 1: .[U5] = 1
End With
With Sheets("TABLEAU")
    ean = Application.CountIf(.Range("A11:A" & .Rows.Count), "><")
    If ean = 0 Then MsgBox "Aucun EAN en feuille TABLEAU !", 48: Exit Sub
    If nref > ean Then MsgBox "Le nombre en U5 ne peut être supérieur à " & ean & " !", 48: Exit Sub
    For i = 11 To .Cells.SpecialCells(xlCellTypeLastCell).Row
        If Trim(.Cells(i, 1)) <> "" Then
            n = n + 1
            If n = nref Then
                For j = i + 1 To .Rows.Count
                    If .Cells(j, 1).Borders(xlEdgeTop).Weight = xlMedium Then Exit For 'repérage de la dernière ligne par la bordure
                Next j
                ajout = nlig + 2 - j + i
                If ajout > 0 Then .Rows(j - 1).Resize(ajout).Insert: j = j + ajout
                With .Range("J" & i & ":M" & j - 1)
                    .ClearContents 'RAZ
                    .Borders.Weight = xlThin
                    .Borders(xlEdgeRight).Weight = xlMedium
                    .Borders(xlEdgeBottom).Weight = xlMedium
                    P.Copy .Cells(1)
                End With
                Application.Goto .Cells(j, 1) 'facultatif
                Exit For
            End If
        End If
    Next i
End With
End Sub

 

[66alex66]

@job75 Merci beaucoup ! Ca va me faire gagner un sac de temps !

Est-il possible d'ajouter une variante permettant d'ajouter ce même tableau à partir de "P11" (dans le tableau) si je choisis de remplir la cellule "V5" plutôt que "U5"

Si cette variante est difficile à insérer ce n'est pas grave, cette macro m'aidera déjà énormément.

Exemple :

Ce qui donnerait ceci :

 

[job75]

Bonjour 66alex66,

si je choisis de remplir la cellule "V5" plutôt que "U5"

Ce n'est pas "plutôt", les 2 cellules U5 et V5 seront traitées par cette macro :

Sub Coller_Tableau()
Dim P As Range, nlig&, zone As Range, ean&, cel As Range, col As Range, nref, n&, i&, j&, ajout&
With Sheets("Fusion BH")
    Set P = .[A1].CurrentRegion.Resize(, 4)
    nlig = P.Rows.Count
    Set zone = .[U5:V5]
End With
With Sheets("TABLEAU")
    ean = Application.CountIf(.Range("A11:A" & .Rows.Count), "><")
    If ean = 0 Then MsgBox "Aucun EAN en feuille TABLEAU !", 48: Exit Sub
    Application.ScreenUpdating = False
    For Each cel In zone
        Set col = IIf(cel.Address = zone(1).Address, .Columns("J"), .Columns("P")) 'colonne de destination
        nref = Int(Val(CStr(cel)))
        cel = nref
        If nref > ean Then
            MsgBox "Le nombre en " & cel.Address(0, 0) & " ne peut être supérieur à " & ean & " !", 48
        ElseIf nref > 0 Then
            n = 0
            For i = 11 To .Cells.SpecialCells(xlCellTypeLastCell).Row
                If Trim(.Cells(i, 1)) <> "" Then
                    n = n + 1
                    If n = nref Then
                        For j = i + 1 To .Rows.Count
                            If .Cells(j, 1).Borders(xlEdgeTop).Weight = xlMedium Then Exit For 'repérage de la dernière ligne par la bordure
                        Next j
                        ajout = nlig + 2 - j + i
                        If ajout > 0 Then .Rows(j - 1).Resize(ajout).Insert: j = j + ajout
                        With col.Cells(i).Resize(j - i, 4)
                            .Clear 'RAZ
                            .Borders.Weight = xlThin
                            P.Copy .Cells(1)
                            .Borders(xlEdgeTop).Weight = xlMedium
                            .Borders(xlEdgeRight).Weight = xlMedium
                            .Borders(xlEdgeBottom).Weight = xlMedium
                        End With
                        Exit For
                    End If
                End If
            Next i
        End If
    Next cel
    Application.Goto .[A1], True 'facultatif
End With
End Sub

A+

 

[job75]

J'ai remplacé ClearContents par Clear pour effacer aussi les couleurs.

Edit : et revu l'application des bordures xlMedium.

 

[66alex66]

Merci beaucoup @job75
Tout fonctionne parfaitement !

Encore merci pour ton aide précieuse.

 

[66alex66]

Bonjour @job75,
Désolé de revenir sur le sujet, tout fonctionne parfaitement.
Seul petit bémol, ce matin en travaillant sur le fichier, je me suis aperçu que dans certaines situations, le collage se réalisait dans le tableau sans tenir compte des formules se trouvant dans la colonne D de la feuille "Fusion BH".

Exemple en image :

 

[job75]

Bonjour 66alex66,

Il suffit de copier-coller les valeurs :

P.Copy .Cells(1) 'copie-colle tout
.Cells(1).Resize(nlig, 4) = P.Value 'copie-colle les valeurs

A+