Excel vba recopie cellules

Résolu/Fermé
marcoturbo Messages postés 26 Date d'inscription jeudi 4 septembre 2014 Statut Membre Dernière intervention 13 janvier 2016 - Modifié par marcoturbo le 3/06/2015 à 15:31
marcoturbo Messages postés 26 Date d'inscription jeudi 4 septembre 2014 Statut Membre Dernière intervention 13 janvier 2016 - 3 juin 2015 à 19:46
Bonjour,

j'ai un petit soucis avec le fichier joint.

https://www.cjoint.com/c/EFdmHt8iTa4

Je voudrais que lors de la copie, les résultats s'affichent sur la même page. ( le premier résultat en colonne A, le second en colonne F, le troisième en colonne K, etc..)


cel.Resize(, 3).Copy Destination:=Sheets("Feuil6").Cells(Sheets("Feuil6").Range("A65536").End(xlUp).Row + 1, 1)


j'ai essayer en changeant le range mais ça marche pas.

merci d'avance.

3 réponses

Gyrus Messages postés 3334 Date d'inscription samedi 20 juillet 2013 Statut Membre Dernière intervention 9 décembre 2016 523
3 juin 2015 à 15:33
Bonjour,

Essaie comme cela :
Sub Transfert()
Dim Cel As Range, DerLig As Long
Sheets("feuil3").Range("A:D").ClearContents
Sheets("feuil6").Range("F:I").ClearContents
Sheets("feuil7").Range("K:N").ClearContents
With Sheets("Feuil5")
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row
For Each Cel In .[A1].Resize(DerLig)

If Cel.Value > 1000 And Cel.Value < 1250 Then
If Cel.Offset(, 2) = "Hall Sportif de 18H45 A 20H15" Then
Cel.Resize(, 3).Copy Destination:=Sheets("Feuil6").Cells(Sheets("Feuil6").Range("A65536").End(xlUp).Row + 1, "A")
End If
End If

If Cel.Value > 2000 And Cel.Value < 2250 Then
If Cel.Offset(, 2) = "Hall Sportif de 16H30 A 18H00" Then
Cel.Resize(, 3).Copy Destination:=Sheets("Feuil6").Cells(Sheets("Feuil6").Range("F65536").End(xlUp).Row + 1, "F")
End If
End If

Next Cel
End With
End Sub

A+
0
marcoturbo Messages postés 26 Date d'inscription jeudi 4 septembre 2014 Statut Membre Dernière intervention 13 janvier 2016
3 juin 2015 à 15:42
merci gyrus, ca marche.

par la meme occasion, ca me colle a partir de la 2eme ligne, comment faire pour l'avoir sur la premiere?

merci.
0
Gyrus Messages postés 3334 Date d'inscription samedi 20 juillet 2013 Statut Membre Dernière intervention 9 décembre 2016 523
3 juin 2015 à 16:38
Voici ton code modifié

Sub Transfert()
Dim CelS As Range, CelC As Range
Dim DerLig As Long, Ligne As Long

Sheets("feuil6").Range("A:D,F:I,K:N").ClearContents
With Sheets("Feuil5")
DerLig = .Cells(Rows.Count, 1).End(xlUp).Row
For Each CelS In .[A1].Resize(DerLig)

If CelS.Value > 1000 And CelS.Value < 1250 Then
If CelS.Offset(, 2) = "Hall Sportif de 18H45 A 20H15" Then
Set CelC = Sheets("Feuil6").Range("A" & Rows.Count).End(xlUp)
If CelC.Row = 1 And CelC.Value = "" Then
CelS.Resize(, 3).Copy Sheets("Feuil6").Range("A" & Rows.Count).End(xlUp)
Else
CelS.Resize(, 3).Copy Sheets("Feuil6").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End If
End If

If CelS.Value > 2000 And CelS.Value < 2250 Then
If CelS.Offset(, 2) = "Hall Sportif de 16H30 A 18H00" Then
Set CelC = Sheets("Feuil6").Range("F" & Rows.Count).End(xlUp)
If CelC.Row = 1 And Cel.Value = "" Then
CelS.Resize(, 3).Copy Sheets("Feuil6").Range("F" & Rows.Count).End(xlUp)
Else
CelS.Resize(, 3).Copy Sheets("Feuil6").Range("F" & Rows.Count).End(xlUp).Offset(1)
End If
End If
End If

Next CelS
End With
End Sub


A+
0
marcoturbo Messages postés 26 Date d'inscription jeudi 4 septembre 2014 Statut Membre Dernière intervention 13 janvier 2016
3 juin 2015 à 19:46
un grand merci ;)
0