XL 2010 Copier coller des colonnes non contigues

  • Initiateur de la discussion Initiateur de la discussion toline
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

toline

XLDnaute Nouveau
Bonjour à tous,

Je fais de nouveau appel à votre aide car j'ai un petit souci sur ma macro. Je cherche, à partir d'un onglet Data, à coller dans un nouvel onglet les lignes répondant à certains critères. Cependant, je ne souhaite pas coller la ligne en entier mais certaines colonnes spécifiques. J'ai donc créé une variable rRange = Worksheets("Data").Range(Columns(4), Columns(34), Columns(36)) pour sélectionner uniquement les colonnes qui m'intéressent.
Mais, quand je lance la macro, un message d'erreur apparaît.

Voici mon code
Code:
Sub IMP_M2()


'Création d'une nouvelle feuille
Dim IMPM2 As Worksheet
Set IMPM2 = Sheets.Add(After:=Sheets(Sheets.Count))
IMPM2.Name = "IMP_M2"
Worksheets("IMP_M2").Cells(1, 1).Value = "A"
Worksheets("IMP_M2").Cells(1, 2).Value = "B"
Worksheets("IMP_M2").Cells(1, 3).Value = "C"
Worksheets("IMP_M2").Cells(1, 4).Value = "D"
Worksheets("IMP_M2").Cells(1, 5).Value = "E"
Worksheets("IMP_M2").Cells(1, 6).Value = "F"
Worksheets("IMP_M2").Cells(1, 7).Value = "G"
Worksheets("IMP_M2").Cells(1, 8).Value = "H"
Worksheets("IMP_M2").Cells(1, 9).Value = "I"
Worksheets("IMP_M2").Cells(1, 10).Value = "J"
Worksheets("IMP_M2").Cells(1, 11).Value = "K"
Worksheets("IMP_M2").Cells(1, 12).Value = "L"
Worksheets("IMP_M2").Cells(1, 13).Value = "M"
Worksheets("IMP_M2").Cells(1, 14).Value = "N"
Worksheets("IMP_M2").Cells(1, 15).Value = "O"
Worksheets("IMP_M2").Cells(1, 16).Value = "P"
Worksheets("IMP_M2").Cells(1, 17).Value = "Q"


 
'Copie
Worksheets("Data").Activate
  Dim i As Integer
  Dim k As Integer
  k = 2
  Dim rRange As Range
  rRange = Worksheets("Data").Range(Columns(4), Columns(34), Columns(36))
  For i = 2 To 100000
If (Worksheets("Data").Cells(i, 140) = Worksheets("MODULE2").Cells(2, 5)) And _
  (Worksheets("Data").Cells(i, 137) = Worksheets("MODULE2").Cells(2, 6)) And _
  (Worksheets("Data").Cells(i, 44) = Worksheets("MODULE2").Cells(3, 1)) Then
  rRange.Select
  Selection.Copy
  Worksheets("IMP_M2").Activate
  Worksheets("IMP_M2").Cells(k, 1).Select
  ActiveSheet.Paste
  k = k + 1
Worksheets("Data").Activate



End If
Next


End Sub

Vous trouverez en PJ mon document exemple. N'hésitez pas à corriger mon code qui est sûrement imparfait, je débute!

Un grand merci
 

Pièces jointes

Bonjour toline,

peut-être en remplaçant:

rRange = Worksheets("Data").Range(Columns(4), Columns(34), Columns(36))
par:

Set rRange = Application.Union(Worksheets("Data").Range("D: D"), Worksheets("Data").Range("AH:AH"), Worksheets("Data").Range("AJ:AJ"))

à+
Philippe
 
Bonjour,
dans une boucle de 100000 lignes ça risque de prendre des plombes 🙂

J'aurais vu ça avec un tableau :
deb-fin-crit1 étant les 3 zones à comparer et sont donc nommées

P.

VB:
Dim F1, F2 As Worksheet
Set F1 = Sheets("data"): Set F2 = Sheets("IMP_M2")
Dim a, b()
Dim Li
Dim i As Integer
Dim k As Integer
k = 2
Li = 1
F1.Activate
a = [A1].CurrentRegion
ReDim b(1 To UBound(a), 1 To 3)
For i = 2 To UBound(a)
   If a(i, 140) = [deb] And a(i, 137) = [fin] And a(i, 44) = [crit1] Then
      b(Li, 1) = a(i, 140)
      b(Li, 2) = a(i, 137)
      b(Li, 3) = a(i, 44)
      Li = Li + 1
   End If
Next i
F2.[A1].Resize(UBound(b), 3) = b
End Sub
 
Dernière édition:
Bonjour le forum

N'hésitez pas à corriger mon code qui est sûrement imparfait, je débute!
Un grand merci

Ce n'est pas une correction de ton code mais une simplification juste pour la partie création de la feuille
VB:
Dim IMPM2 As Worksheet, Rng As Range
'Création d'une nouvelle feuille
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "IMP_M2": Set IMPM2 = ActiveSheet
Set Rng = IMPM2.Range("A1:Q1")
Rng.Formula = "=CHAR(64+COLUMN())": Rng.Value = Rng.Value
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
1
Affichages
180
Réponses
4
Affichages
177
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
479
Retour