XL 2010 Copier coller des colonnes non contigues

[toline]

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

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

 

[phlaurent55]

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]

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.

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

 

[Yurperqod]

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

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