Microsoft 365 Copie de cellules non adjacentes en Vba

Thierry054

XLDnaute Nouveau
Bonjour,
Je suis tout nouveau sur ce forum et débutant en Vba.
J'ai tenté de trouver la réponse à mon problème dans le forum et sur le net mais je n'ai pas trouvé de solution qui me permette de le résoudre.
Je vous joins mon fichier exemple pour lequel un collègue m'a déjà aidé sur la macro.
Il comporte 2 feuilles :
- la feuille 1 est la source des données
- la feuille 2 est celle dans laquelle copier les données.

Je souhaite, pour chaque ligne qui comporte un caractère en colonne H copier les données présentes en colonnes A, B, F, G.
Ma macro fonctionne pour recopier toutes les colonnes mais je ne trouve pas comment faire pour ne copier que les colonnes ci-dessus...
 

Pièces jointes

  • TestCopiePrix.xlsm
    108.3 KB · Affichages: 12
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

Je pensais que tu avais écrit 40 000 au lieu de 400 000 :oops:. Je vais voir demain samedi ce qu'il en est avec 40 000 lignes.

Juste pour le fun (ce n'est pas la méthode la plus rapide), une procédure qui n'utilise que des "manipulations Excel".
VB:
Sub ViaExcel()
Dim max&, deb
   deb = Timer: Application.ScreenUpdating = False
   With Sheets("Feuil1")
      Sheets("Feuil2").Columns("a:e").ClearContents
      max = .Range("a1").CurrentRegion.Rows.Count
      .Range("a:d").Resize(max).Copy Sheets("Feuil2").Range("a1")
   End With
   With Sheets("Feuil2")
      .Columns("e:e").Resize(max).Formula = "=IF(ROUND(RC[-2],2)<>ROUND(RC[-1],2),0,#N/A)"
      .Columns("e:e").Resize(max).Value = .Columns("e:e").Resize(max).Value
      [e1] = 0
      .Columns("a:e").Resize(max).Sort key1:=.Range("e1"), order1:=xlAscending, Header:=xlYes
      On Error Resume Next
      .Columns("e:e").Resize(max).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Resize(, 5).Delete
      .Columns("e:e").Resize(max).ClearContents
   End With
   MsgBox "C'est fini en : " & Format(Timer - deb, "#0.00\ sec.")
End Sub
 

Pièces jointes

  • Thierry054- TestCopiePrix- v4 .xlsm
    34.7 KB · Affichages: 3

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
Re,

Je pensais que tu avais écrit 40 000 au lieu de 400 000 :oops:. Je vais voir demain samedi ce qu'il en est avec 40 000 lignes.

Juste pour le fun (ce n'est pas la méthode la plus rapide), une procédure qui n'utilise que des "manipulations Excel".
VB:
Sub ViaExcel()
Dim max&, deb
   deb = Timer: Application.ScreenUpdating = False
   With Sheets("Feuil1")
      Sheets("Feuil2").Columns("a:e").ClearContents
      max = .Range("a1").CurrentRegion.Rows.Count
      .Range("a:d").Resize(max).Copy Sheets("Feuil2").Range("a1")
   End With
   With Sheets("Feuil2")
      .Columns("e:e").Resize(max).Formula = "=IF(ROUND(RC[-2],2)<>ROUND(RC[-1],2),0,#N/A)"
      .Columns("e:e").Resize(max).Value = .Columns("e:e").Resize(max).Value
      [e1] = 0
      .Columns("a:e").Resize(max).Sort key1:=.Range("e1"), order1:=xlAscending, Header:=xlYes
      On Error Resume Next
      .Columns("e:e").Resize(max).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Resize(, 5).Delete
      .Columns("e:e").Resize(max).ClearContents
   End With
   MsgBox "C'est fini en : " & Format(Timer - deb, "#0.00\ sec.")
End Sub
Mea culpa 😱 , je viens de me rendre compte que c'est bien 400 000, mes yeux mon joués des tours, voilà ce qui arrive qd on travail trop; c'est vrai que le chiffre de la message box m'a pas aidé🤔 quand j'ai ouvert le fichier :
1685146707659.png

bon au moins c'est pas un bug sur Mac c'est déjà ça
désolé …
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Mea culpa 😱 , je viens de me rendre compte que c'est bien 400 000, mes yeux mon joués des tours, voilà ce qui arrive qd on travail trop; c'est vrai que le chiffre de la message box m'a pas aidé🤔 quand j'ai ouvert le fichier :
Non c'est à moi de battre ma coulpe. Je n'ai pas vu qu'un 0 a sauté. J'ai remplacé le fichier en cause par un fichier avec le bon message. Mille excuses pour cette bévue :rolleyes:.
 
Dernière édition:

Discussions similaires

Réponses
24
Affichages
335