Copier des données via la date et le tous en ligne
P
Bonsoir voilà le problème, je voudrais copier les données de " C4:Q148 " et les coller dans la feuille " Récap envoie " en face de la date ici 19-nov.-14 et sans les blancs voir exemple dans la feuille " Récap envoie " à la date du 18-nov.-14
Pour trouver la date sa colle
' +------ Recherche de la date du jour ----------------------------+
Sheets("Récap envoie").Select ' Ouvre la feuille Récap envoie
Range("A1").Select ' Va a la colonne en A1
Dim Ligne
Ligne = Application.Match(CSng(Date), Columns("A"), 0)
If Not IsError(Ligne) Then
Range("A" & Ligne).Select
Else
MsgBox "Date " & Date & " non trouvée"
End If
ActiveCell.Offset(0, 1).Select ' et va de 2 cellules à droiteP
Bonsoir suit au poste que j'ai posé hier j'ai réussi à faire se code mais je le trouve pas terrible même si sa marche, je vous remercie d’avance si vous pourriez me l’améliorer
Range("C4:Q148").Select
Selection.Copy
Range("BB4").Select
ActiveSheet.Paste
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("BC4:BC148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BD4:BD148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BE4:BE148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BF4:BF148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BG4:BG148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BH4:BH148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BI4:BI148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BJ4:BJ148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BK4:BK148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BL4:BL148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BM4:BM148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BN4:BN148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BO4:BO148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BP4:BP148").Select
Selection.Copy
Range("BB4").Select ' Va a la colonne BB
ActiveCell.End(xlDown).Select ' Recherche la dernière cellule écrite
ActiveCell.Offset(1, 0).Select ' Dernière celulle + 1
ActiveSheet.Paste
Range("BC4:BP148").Select ' Effacement des celulles AJ1:AO1 de la
Selection.ClearContents ' Feuille " Référence "
Range("BB4:BB2200").Select
Selection.Copy
Sheets("Récap envoie").Select
' +------ Recherche de la date du jour ----------------------------+
Range("A1").Select ' Va a la colonne en A1
Dim Ligne
Ligne = Application.Match(CSng(Date), Columns("A"), 0)
If Not IsError(Ligne) Then
Range("A" & Ligne).Select
Else
MsgBox "Date " & Date & " non trouvée"
End If
ActiveCell.Offset(0, 1).Select ' et va de 1 cellules à droite
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Range("B1").Select
End Subg
Bonjour
Un essai :
Dim dte, lgn, i, j, col
Sub Essai_gmb()
dte = InputBox("Donner la date :", "Date où reporter", "19/11/2014")
If dte = "" Then End
With Sheets("Récap envoie")
lgn = .Range("A:A").Find(CDate(dte)).Row '
For i = 4 To 148
For j = 3 To 17
If Cells(i, j).Value <> "" Then
col = .Cells(lgn, Columns.Count).End(xlToLeft).Column + 1
.Cells(lgn, col) = Cells(i, j).Value
End If
Next j
Next i
End With
End SubP
Bonsoir Gmb et merci marche impec, mais petit bémol es que la date peut ce mètre automatiquement dans l’InputBox pour éviter les erreurs comme on valide les données le jour même, et laisser le choix de pouvoir changer la date en cas ou merci et si tu peux me commenter ton code pour essayer de comprendre comment ça marche
g
Qu'à cela ne tienne !
Voilà :
Dim dte, lgn, i, j, col
Sub Essai_gmb()
dte = InputBox("Donner la date :", "Date où reporter", Date)
If dte = "" Then End
With Sheets("Récap envoie")
lgn = .Range("A:A").Find(CDate(dte)).Row '
For i = 4 To 148
For j = 3 To 17
If Cells(i, j).Value <> "" Then
col = .Cells(lgn, Columns.Count).End(xlToLeft).Column + 1
.Cells(lgn, col) = Cells(i, j).Value
End If
Next j
Next i
End With
End SubP
Je te remercie Gmb c'est génial marche au top