Copier coller ligne / a une cellule

[ABDELHAK]

Bonjour à tous,

J’aimerais un bon coup de pouce pour réaliser une macro qui effectuerait des copier coller à partir d’une cellules distinctes.
En gros, j’ai un fichier avec 2 feuilles.
La première feuille est composée de plusieurs tableaux.
La seconde est composée d’un tableau 1 avec une ligne, les cellules de celle-ci contiennent des valeurs.
Ci les valeurs du tableau 1 sont identiques aux valeurs des cellules de la feuille 1, j’aimerais que la macro exécute un copier coller de toute la ligne vers la feuille 2.
Je joins un fichier pour que vous puissiez mieux comprendre, du moins je l’espère.

Dans tous les cas, merci d’avance pour votre aide.

 

[job75]

Re : Copier coller ligne / a une cellule

Bonjour ABDELHAK,

J’aimerais un bon coup de pouce pour réaliser une macro (...)

Vous l'aurez quand vous aurez donné suite aux réponses qu'on vous donne :

https://www.excel-downloads.com/threads/copier-des-cellules-vers-plusieurs-feuilles.200081/

https://www.excel-downloads.com/thr...djacentes-de-memes-valeurs-d1-tableau.201627/

C'est la 2ème fois que je vous remonte les bretelles, vous avez la comprenette difficile

A+

 

[job75]

Re : Copier coller ligne / a une cellule

Bonjour ABDELAK,

Bon vous avez fait un effort sur l'un des fils, mais on ne sait toujours pas si les solutions proposées vous conviennent.

C'est si dur que ça de répondre ?

Alors maintenant pour ce fil voici une solution.

Je ne suis pas sûr que c'est ce que vous voulez car les résultats que vous montrez en Feuil2 me paraissent assez incohérents.

Sub Transfert()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim n%, h&, ref As Range, c As Range, sup As Range
Application.ScreenUpdating = False
With Feuil2
  .Rows("6:" & .Rows.Count).Clear 'RAZ
  n = .Cells(3, .Columns.Count).End(xlToLeft).Column - 4
  If n < 1 Then Exit Sub 'sécurité
  h = Application.Max(5, Feuil1.[A65536].End(xlUp).Row + 1)
  Feuil1.[A1].Resize(h, n + 1).Copy .[A6]
  Set ref = .[E3].Resize(, n)
  For Each c In .[A6].Resize(h)
    If c <> "" Then If c <> "EMPLACEMENTS" And Application.CountIf(ref, c) = 0 _
      Then Set sup = Union(c.Resize(2), IIf(sup Is Nothing, c.Resize(2), sup))
  Next
  If Not sup Is Nothing Then sup.EntireRow.Delete
End With
End Sub

La macro copie le tableau en Feuil1 puis supprime les lignes qui ne répondent pas au critère.

Fichier joint.

PS : Application.CountIf c'est la fonction NB.SI.

A+

 

[phlaurent55]

Re : Copier coller ligne / a une cellule

Bonjour à tous,

C'est la 2ème fois que je vous remonte les bretelles, vous avez la comprenette difficile

apparemment, une 3 ème fois serait nécessaire car la question viens encore d'être posée ici:
https://www.excel-downloads.com/threads/copier-coller-ligne-a-une-cellule-2.203050/

à+
Philippe

 

[job75]

Re : Copier coller ligne / a une cellule

Re, salut Philippe,

apparemment, une 3 ème fois serait nécessaire car la question viens encore d'être posée ici:
https://www.excel-downloads.com/threads/copier-coller-ligne-a-une-cellule-2.203050/

Oui, c'est récurrent, vraiment pas croyable !

La macro précédente copiait uniquement les colonnes 1 à 14.

Si l'on veut copier toutes les colonnes en Feuil1 :

Sub Transfert()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim n%, h&, ref As Range, c As Range, sup As Range
Application.ScreenUpdating = False
With Feuil2
  .Rows("6:" & .Rows.Count).Clear 'RAZ
  n = .Cells(3, .Columns.Count).End(xlToLeft).Column - 4
  If n < 1 Then Exit Sub 'sécurité
  h = Application.Max(5, Feuil1.[A65536].End(xlUp).Row + 1)
  Feuil1.Rows(1).Resize(h).Copy .[A6] 'copie les lignes entières
  Set ref = .[E3].Resize(, n)
  For Each c In .[A6].Resize(h)
    If c <> "" Then If c <> "EMPLACEMENTS" And Application.CountIf(ref, c) = 0 _
      Then Set sup = Union(c.Resize(2), IIf(sup Is Nothing, c.Resize(2), sup))
  Next
  If Not sup Is Nothing Then sup.EntireRow.Delete
End With
End Sub

Fichier (2).

A+

 

[ABDELHAK]

Message de 10000000000000000000 et encore plus de remerciements

Bonjour,

Je ne vous remercierai jamais assez pour votre aide. J’éprouve un immense respect pour votre personne ainsi que pour ce que vous faîtes pour autrui. Votre altruisme me laisse sans voix. Vous êtes pour moi un exemple à suivre et je ne mâche pas mes mots. J’ai bien reçu « TRANSFERT(2) » et il fonctionne parfaitement bien.
Pour votre information, l’exécution est très lente ( + de 20 min ). J’avais omis de vous dire que la taille de mon fichier est de 929 Ko. La macro doit chercher dans 107120 cellules ce qui doit être énorme. De plus, je suppose que mon matériel doit être un peu dépassé. Mais j’ai néanmoins trouver une astuce pour le faire fonctionner en réduisant tout simplement la taille de mon big fichier.
J’espère vous avoir tout dit.
Je vous présente encore mes excuses pour les désagréments que j’ai causé aujourd’hui au forum. Et encore mille merci’sssssssss.
Amicalement vôtre

ABDELHAK

 

[phlaurent55]

Re : Message de 10000000000000000000 et encore plus de remerciements

Bon dimanche à tous,

Bonjour,

Pour votre information, l’exécution est très lente ( + de 20 min ) ...............

ceci va peut-être accélérer la procédure:

Sub Transfert()
Application.Calculation = xlCalculationManual
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim n%, h&, ref As Range, c As Range, sup As Range
Application.ScreenUpdating = False
With Feuil2
  .Rows("6:" & .Rows.Count).Clear 'RAZ
  n = .Cells(3, .Columns.Count).End(xlToLeft).Column - 4
  If n < 1 Then Exit Sub 'sécurité
  h = Application.Max(5, Feuil1.[A65536].End(xlUp).Row + 1)
  Feuil1.Rows(1).Resize(h).Copy .[A6] 'copie les lignes entières
  Set ref = .[E3].Resize(, n)
  For Each c In .[A6].Resize(h)
    If c <> "" Then If c <> "EMPLACEMENTS" And Application.CountIf(ref, c) = 0 _
      Then Set sup = Union(c.Resize(2), IIf(sup Is Nothing, c.Resize(2), sup))
  Next
  If Not sup Is Nothing Then sup.EntireRow.Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

à+
Philippe

 

[job75]

Re : Copier coller ligne / a une cellule

Bonjour ABDELHAK, Philippe,

L'exécution est très lente à cause de la multitude des cellules fusionnées.

Faites le test : défusionnez toutes les cellules en Feuil1 et exécutez la macro.

Ces cellules fusionnées sont parfaitement inutiles : il suffit de donner aux lignes la hauteur que l'on veut.

Modifiez donc le fichier et revenez, j'adapterai la macro.

A+

 

[job75]

Re : Copier coller ligne / a une cellule

Re,

Si vous avez pris la (bonne) décision de défusionner les cellules en Feuil1, cette macro permet de le faire facilement :

Sub Defusionner()
Dim c As Range, h As Byte
Application.ScreenUpdating = False
For Each c In Feuil1.Range("A1", Feuil1.[A65536].End(xlUp))
  If c.MergeArea.Count > 1 Then 'si cellule fusionnée
    c.EntireRow.UnMerge 'défusionne
    h = IIf(c = "EMPLACEMENTS", 3, 1)
    c(2).Resize(h).EntireRow.Delete 'supprime les lignes vides
    c.EntireRow.RowHeight = (h + 1) * c.Height 'hauteur ligne
  End If
Next
End Sub

L'exécution prend bien sûr un certain temps.

Ensuite allez en Feuil2, cliquez sur le bouton "Transfert" et voyez la différence

Fichier (3).

A+

 

[job75]

Re : Copier coller ligne / a une cellule

Bonjour ABDELHAK,

Si l'on ne veut pas défusionner toutes les cellules, on peut quand même rendre la macro plus rapide en défusionnant les lignes avant de les supprimer :

If Not sup Is Nothing Then
  sup.EntireRow.UnMerge 'défusionne
  sup.EntireRow.Delete
End If

Fichier (2 bis), bien sûr moins rapide que la version (3).

A+