Excel vba recopie cellules

Résolu
marcoturbo Messages postés 26 Date d'inscription   Statut Membre Dernière intervention   -  
marcoturbo Messages postés 26 Date d'inscription   Statut Membre Dernière intervention   -
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

Réponse 1 / 3
Gyrus Messages postés 3334 Date d'inscription   Statut Membre Dernière intervention   526
 
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
Réponse 2 / 3
marcoturbo Messages postés 26 Date d'inscription   Statut Membre Dernière intervention  
 
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
Réponse 3 / 3
Gyrus Messages postés 3334 Date d'inscription   Statut Membre Dernière intervention   526
 
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   Statut Membre Dernière intervention  
 
un grand merci ;)
0