XL 2010 Copier coller des colonnes non contigues

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

  • Test macro.xlsm
    28.3 KB · Affichages: 41

phlaurent55

Nous a quittés en 2020
Repose en paix
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
 

gosselien

XLDnaute Barbatruc
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:

Yurperqod

XLDnaute Occasionnel
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
 

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof