Excel vba recopie cellules

Résolu
marcoturbo Messages postés 27 Statut Membre -  
marcoturbo Messages postés 27 Statut Membre -
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 3360 Statut Membre 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 27 Statut Membre
 
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 3360 Statut Membre 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 27 Statut Membre
 
un grand merci ;)
0