selection plagemulti feuille sur date

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion MASSJIPE
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
MASSJIPE

MASSJIPE

XLDnaute Impliqué
Bonjour à tous
Je voudrais en fonction de la date du jour (=AUJOURDHUI() qui est en B1 de la feuille import sélectionner la plage dans les autres feuilles en fonction de cette date j'ai un code mais je ne sais pas quoi modifier
Merci
Code: 
Option Explicit
Sub Consolidation()
Dim derLig As Integer
Dim DerL&
Cells.Select
    Selection.ClearContents 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ActiveWindow.SmallScroll Down:=-15
    Range("B1").Select
    '
     Cells.ClearContents
     With Sheets("IMPORT")
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURBRIN1").Range("A1:E" & Sheets("JOURBRIN1").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURUMECA").Range("A1:E" & Sheets("JOURUMECA").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURBRIN2").Range("A1:E" & Sheets("JOURBRIN2").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURMECAPORTE").Range("A1:E" & Sheets("JOURMECAPORTE").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURBDM").Range("A1:E" & Sheets("JOURBDM").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         DerL = Range("A65535").End(xlUp).Row + 1
         Sheets("JOURDLI").Range("A1:E" & Sheets("JOURDLI").Range("A65535").End(xlUp).Row).Copy .Cells(DerL, 1)
         With Sheets("IMPORT").Activate
 derLig = Cells(65000, 2).End(xlUp).Row
 ActiveSheet.PageSetup.PrintArea = "A1:E" & derLig
  End With
     End With
End Sub
 
Trier par date Trier par votes
Re : selection plagemulti feuille sur date

Bonjour.
Moi non plus étant donné que je n'ai pas votre classeur sous les yeux me permettant de voir où est la date qui doit y correspondre, ni si elle peut être sur plusieurs lignes.
Mais peut être pourriez vous utiliser ces fonctions:
VB: 
Function  ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As  String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)
End Function

Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & Opé & Valeur)
End Function

Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
Set ColLignesOùCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function

Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End  Function
Exemple d'utilisation dans votre cas :
VB: 
ColLignesOùRelat(Worksheets("JOURBRIN1").[A1:E1], "A",  "=", .[B1].Value).Copy .Cells(DerL, 1)
 
Dernière édition:
Vote positif 0 Vote négatif
Re : selection plagemulti feuille sur date

VB: 
Option Explicit
Private Dat As Date

Sub Consolidation()
Dat = Feuil21.[B1].Value
Feuil21.[2:60000].Delete
Prendre Worksheets("JOURBRIN1")
Prendre Worksheets("JOURUMECA")
Prendre Worksheets("JOURBRIN2")
Prendre Worksheets("JOURMECAPORTE")
Prendre Worksheets("JOURBDM")
Prendre Worksheets("JOURDLI")
Feuil21.PageSetup.PrintArea = "A1:E" & Feuil21.[A65535].End(xlUp).Row
End Sub
'

Sub Prendre(ByVal F As Worksheet)
Dim Src As Range
Set Src = ColLignesOùRelat(F.[A3:E3], "A", "=", Dat)
If Src Is Nothing Then Exit Sub
Application.Union(F.[A1:E2], Src).Copy Feuil21.[A65535].End(xlUp).Offset(1)
End Sub
'

Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
Set ColLignesOùRelat = LignesOùRelat(CelDéb, ColQuoi, Opé, Valeur): If Not ColLignesOùRelat Is Nothing Then _
Set ColLignesOùRelat = Intersect(ColLignesOùRelat, CelDéb.EntireColumn)
End Function

Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
Select Case VarType(Valeur)
   Case vbString: Valeur = """" & Replace(Valeur, """", """""") & """"
   Case vbDate: Valeur = Trim$(Str$(CDbl(Valeur)))
   Case Else: Valeur = Trim$(Str$(Valeur)): End Select
Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & Opé & Valeur)
End Function

Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
Set ColLignesOùCondR1C1 = LignesOùCondR1C1(CelDéb, CondR1C1): If Not ColLignesOùCondR1C1 Is Nothing Then _
Set ColLignesOùCondR1C1 = Intersect(ColLignesOùCondR1C1, CelDéb.EntireColumn)
End Function

Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function
 
Vote positif 0 Vote négatif
Re : selection plagemulti feuille sur date

Alors comme ça:
VB: 
Option Explicit
Private Dat As Date, EQ As String

Sub Consolidation()
Dat = Feuil21.[B1].Value
EQ = Feuil21.[C1].Value
Feuil21.[2:60000].Delete
Prendre Worksheets("JOURBRIN1")
Prendre Worksheets("JOURUMECA")
Prendre Worksheets("JOURBRIN2")
Prendre Worksheets("JOURMECAPORTE")
Prendre Worksheets("JOURBDM")
Prendre Worksheets("JOURDLI")
Feuil21.PageSetup.PrintArea = "A1:E" & Feuil21.[A65535].End(xlUp).Row
End Sub
'

Sub Prendre(ByVal F As Worksheet)
Dim Src As Range
'Set Src = ColLignesOùRelat(F.[A3:E3], "A", "=", Dat)
Set Src = ColLignesOùCondR1C1(F.[A3:E3], "AND(RC1=" & Trim$(Str$(CDbl(Dat))) & ",RC3=""" & EQ & """)")
If Src Is Nothing Then Exit Sub
Application.Union(F.[A1:E2], Src).Copy Feuil21.[A65535].End(xlUp).Offset(1)
End Sub
Ou bien comme ça :
VB: 
Option Explicit
Private Condition As String

Sub Consolidation()
Condition = "AND(RC1=" & Trim$(Str$(CDbl(Feuil21.[B1].Value))) _
   & ",RC3=""" & Feuil21.[C1].Value & """)"
Feuil21.[2:60000].Delete
Prendre Worksheets("JOURBRIN1")
Prendre Worksheets("JOURUMECA")
Prendre Worksheets("JOURBRIN2")
Prendre Worksheets("JOURMECAPORTE")
Prendre Worksheets("JOURBDM")
Prendre Worksheets("JOURDLI")
Feuil21.PageSetup.PrintArea = "A1:E" & Feuil21.[A65535].End(xlUp).Row
End Sub
'

Sub Prendre(ByVal F As Worksheet)
Dim Src As Range
'Set Src = ColLignesOùRelat(F.[A3:E3], "A", "=", Dat)
Set Src = ColLignesOùCondR1C1(F.[A3:E3], Condition)
If Src Is Nothing Then Exit Sub
Application.Union(F.[A1:E2], Src).Copy Feuil21.[A65535].End(xlUp).Offset(1)
End Sub
Le reste ne change pas.
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

P
  • Question Question
XL 2010 Recopie de la date du jour jusqu'à la dernière ligne non vide
Réponses
5
Affichages
118
philmaure
P
lynyrd
  • Question Question
XL 2019 Prénoms à souhaiter
2
Réponses
15
Affichages
645
lynyrd
lynyrd
ph.vanne
  • Question Question
Autres fenêtre "Publication"
Réponses
10
Affichages
754
ph.vanne
ph.vanne
arck
  • Résolu(e)
XL 2019 macro avec fonction copié coller si rempli par la macro
Réponses
12
Affichages
594
AtTheOne
AtTheOne
Electron24
  • Résolu(e)
Microsoft 365 Virgules dans ListView
Réponses
5
Affichages
451
Electron24
Electron24
U
  • Question Question
Autres [RÉSOLU] Compléter la macro mais comment et où?
Réponses
2
Affichages
684
un internaute
U
N
  • Question Question
XL 2013 Utilisé deux CommandButton_Click dans la même feuil
Réponses
4
Affichages
405
patricktoulon
patricktoulon
J
  • Question Question
XL 2021 transfert listview vers feuille excel
Réponses
9
Affichages
705
Piment
P
L
  • Résolu(e)
Microsoft 365 Trie par Date & Heure
Réponses
8
Affichages
618
Le Rouky
L
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
Nicolas JACQUIN
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
484
job75
job75
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
1 K
CortoXls
C
S
  • Résolu(e)
Microsoft 365 VBA Concaténer contenu de plusieurs cellules dans une seule avec séparateurs / évolutifs
Réponses
3
Affichages
579
spike29
S
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
729
Oneida
Oneida
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
606
safranien
S
VBA_dev_Anne_Marie
  • Question Question
Microsoft 365 VBA : copier les adresses
Réponses
7
Affichages
970
VBA_dev_Anne_Marie
VBA_dev_Anne_Marie
S
  • Résolu(e)
Microsoft 365 Mailing mise en forme HTML : revenir à la ligne automatique si trop de texte saisie
2
Réponses
17
Affichages
1 K
spike29
S
Jojo973
  • Question Question
Microsoft 365 Trier des données et les afficher sur une autre feuille
Réponses
10
Affichages
681
Jojo973
Jojo973
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
777
patricktoulon
patricktoulon
F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
4 K
fanou06
F
Retour