seclection date a partir de date d'aujourd'hui maccro

R

rak

XLDnaute Junior
bonjour
j'aimerai que cette opreration s'effectue automatiquement en prenant en compte les date de la semaine dernieres
voila le script que j'obtient apres avoir effectuer le filtre test Macro
'
Macro enregistrée le 29/05/2009 par RESA3
'

'
Selection.AutoFilter Field:=4, Criteria1:=">=20090511", Operator:=xlAnd, _
Criteria2:="<=20090516"
End Sub

merci beaucoup
 
Trier par date Trier par votes
tototiti2008

tototiti2008

XLDnaute Barbatruc
Re : seclection date a partir de date d'aujourd'hui maccro

Bonjour rak,

à tester :

Code: 
Dim Deb As String, Fin As String
Deb = Format(Date - 6 - Weekday(Date, vbMonday), "YYYYMMDD")
Fin = Format(Date - 1 - Weekday(Date, vbMonday), "YYYYMMDD")
Selection.AutoFilter Field:=4, Criteria1:=">=" & Deb, Operator:=xlAnd, _
Criteria2:="<=" & Fin
 
Vote positif 0 Vote négatif
tototiti2008

tototiti2008

XLDnaute Barbatruc
Re : seclection date a partir de date d'aujourd'hui maccro

Re,

quelques explications :
Date renvoie la date du jour
Weekday(Date, vbMonday), renvoir le numéro du jour de la semaine (lundi = 1, dimanche = 7)
Format permet de renvoyer les dates sous le format AAAAMMJJ

exemple : on est vendredi 29/5
pour aujourd'hui, weekday = 5
à la date d'aujourd'hui, on retranche 6+5 = 11 jours donc on se retrouve le 18/5 donc bien le lundi de la semaine dernière.
à la date d'aujourd'hui, on retranche 1+5 = 6 jours donc on se retrouve le 23/5 donc bien le samedi de la semaine dernière.
 
Vote positif 0 Vote négatif
R

rak

XLDnaute Junior
Re : seclection date a partir de date d'aujourd'hui maccro

bonjour et merci pour ton explication c sympas de repondre rapidement mais je voudrait avoir une aide sur ce script 'jaimerai renommer le nom de la feuille automatiquement avec le nom de la feuille precedement enregistrer +1


exemple la semaine derniere s18 la semaine prochaine s18+1 =s19
comment faire
Sub test3()
'
' test3 Macro
' Macro enregistrée le 29/05/2009 par RESA3
'

'
Sheets("feuille1").Select
Sheets("feuille1").Name = "s22"
Range("J10112").Select
End Sub
merci beaucoup pour ton aide
 
Vote positif 0 Vote négatif
K

keepcool183

XLDnaute Occasionnel
Re : seclection date a partir de date d'aujourd'hui maccro

Bonjour Rak, tototiti2008,

Une modif dans ton code
rak à dit:
Sub test3()
'
' test3 Macro
' Macro enregistrée le 29/05/2009 par RESA3
'
Code: 
'    Nosemaine= sheets("tafeuille").range("Ta cellule")
    Sheets("feuille1").Select
    Sheets("feuille1").Name = nosemaine+1
    Range("J10112").Select
End Sub
merci beaucoup pour ton aide
Cliquez pour agrandir...

ca devrait régler ton soucis

Edit : Si c'est suivant la dernière feuille +1 alors mettre sheets.count+1 et virer nosemaine :)
A+
 
Dernière édition:
Vote positif 0 Vote négatif
R

rak

XLDnaute Junior
Re : seclection date a partir de date d'aujourd'hui maccro

re et encore merci de me repondre aussi rapidement
je veut renommer la nouvelle feuille a partir des feuilles anterieurs +1 de la derniere feuille existante
expl derniere feuille cree s18 nouvelle feuille s18+1 = s19

merci
 
Dernière édition:
Vote positif 0 Vote négatif
tototiti2008

tototiti2008

XLDnaute Barbatruc
Re : seclection date a partir de date d'aujourd'hui maccro

Re,

rak, merci d'éviter les messages privés pour ce qui concerne le fil, tout le monde peut participer comme ça...

un essai :
 

Pièces jointes

  • Classeur1.xls
    25.5 KB · Affichages: 81
  • Classeur1.xls
    25.5 KB · Affichages: 85
  • Classeur1.xls
    25.5 KB · Affichages: 95
Vote positif 0 Vote négatif
R

rak

XLDnaute Junior
Re : seclection date a partir de date d'aujourd'hui maccro

ok desole tototiti ton bouton fonctionne tres bien comme tjrs mais jaimerai a jouter ce script a une autre macro qui celle ci ouvre une nouvelle feuille jaimerai donc que renomer la fauille sans utiliser le bouton je voudrais que cela ce deroule automatiquement est ce possible ?

merci encore pour m'avoir repondu aussi rapidement
 
Vote positif 0 Vote négatif
R

rak

XLDnaute Junior
Re : seclection date a partir de date d'aujourd'hui maccro

voici ce que j'ai effectuer mais cela ne marche pas

' Macro1 Macro
' Macro enregistrée le 28/05/2009 par RESA3
'
Sub AjouteFeuille()
Dim Wks As Worksheet, numsem As Long
numsem = 0
For Each Wks In ThisWorkbook.Worksheets
If UCase(Wks.Name) Like "S*" And IsNumeric(Right(Wks.Name, Len(Wks.Name) - 1)) Then
If CLng(Right(Wks.Name, Len(Wks.Name) - 1)) > numsem Then numsem = CLng(Right(Wks.Name, Len(Wks.Name) - 1))
End If
Next Wks
ThisWorkbook.Worksheets.Add after:=Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "s" & numsem + 1
End Sub

'
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=D:\stat\stat05.mdb;Mode=Share Deny Write;Extended Propert" _
, _
"ies="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:" _
, _
"Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password" _
, _
"="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLE" _
, "DB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"), Destination _
:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("inscription")
.Name = "stat05"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "D:\stat\stat05.mdb"
.Refresh BackgroundQuery:=False
End With
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft

Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Rows("1:1").Select
Selection.AutoFilter

Selection.AutoFilter Field:=13, Criteria1:="A"

Range("N12499").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-12497]C:R[-1]C)"
Range("N12499").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

End Sub


merci de bein vouloir m'aider
 
Vote positif 0 Vote négatif
tototiti2008

tototiti2008

XLDnaute Barbatruc
Re : seclection date a partir de date d'aujourd'hui maccro

Re,

essaye en supprimant les lignes en rouge :

Code: 
Sub Macro1()
' Macro1 Macro
' Macro enregistrée le 28/05/2009 par RESA3
'
[COLOR=red]Sub AjouteFeuille()
[/COLOR]Dim Wks As Worksheet, numsem As Long
numsem = 0
For Each Wks In ThisWorkbook.Worksheets
If UCase(Wks.Name) Like "S*" And IsNumeric(Right(Wks.Name, Len(Wks.Name) - 1)) Then
If CLng(Right(Wks.Name, Len(Wks.Name) - 1)) > numsem Then numsem = CLng(Right(Wks.Name, Len(Wks.Name) - 1))
End If
Next Wks
ThisWorkbook.Worksheets.Add after:=Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "s" & numsem + 1
[COLOR=red]End Sub
[/COLOR]
'
[COLOR=red]ActiveWorkbook.Worksheets.Add
[/COLOR]With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=" """;User ID=Admin;Data Source=D:\stat\stat05.mdb;Mode=Share Deny Write;Extended Propert" _
, _
"ies="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:" _
, _
"Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password" _
, _
"="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLE" _
, "DB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"), Destination _
:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("inscription")
.Name = "stat05"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "D:\stat\stat05.mdb"
.Refresh BackgroundQuery:=False
End With
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft

Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Rows("1:1").Select
Selection.AutoFilter

Selection.AutoFilter Field:=13, Criteria1:="A"

Range("N12499").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-12497]C:R[-1]C)"
Range("N12499").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

End Sub
 
Vote positif 0 Vote négatif
R

rak

XLDnaute Junior
Re : seclection date a partir de date d'aujourd'hui maccro

bonjour tototiti2008
merci de ta reponse mais cela ne marche pas .une fois lancée la macro m'indique erreur de syntaxe

Sub Macro1()
' Macro1 Macro
' Macro enregistrée le 28/05/2009 par RESA3
'

Dim Wks As Worksheet, numsem As Long
numsem = 0
For Each Wks In ThisWorkbook.Worksheets
If UCase(Wks.Name) Like "S*" And IsNumeric(Right(Wks.Name, Len(Wks.Name) - 1)) Then
If CLng(Right(Wks.Name, Len(Wks.Name) - 1)) > numsem Then numsem = CLng(Right(Wks.Name, Len(Wks.Name) - 1))
End If
Next Wks
ThisWorkbook.Worksheets.Add after:=Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "s" & numsem + 1
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=" """;User ID=Admin;Data Source=D:\stat\stat05.mdb;Mode=Share Deny Write;Extended Propert" _
, _
"ies="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:" _
, _
"Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password" _
, _
"="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLE" _
, "DB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"), Destination _
:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("inscription")
.Name = "stat05"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "D:\stat\stat05.mdb"
.Refresh BackgroundQuery:=False
End With
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft

Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft

Rows("1:1").Select
Selection.AutoFilter

Selection.AutoFilter Field:=13, Criteria1:="A"

Range("N12499").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-12497]C:R[-1]C)"
Range("N12499").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With

End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Macro filtre pour sélectionner les dates portant sur les 2 mois à venir à partir de la date du jour
Réponses
2
Affichages
866
michel.dupont
M
C
  • Question
XL 2019 Filtrage de données en VBA
Réponses
11
Affichages
1 K
Phil69970
Phil69970
F
  • Question
Macro Intervalle de date et heure qui ne fonctionne pas
Réponses
2
Affichages
1 K
F2T
F
A
  • Question
XL 2010 [Résolu] Créer un filtre date basé sur la valeur d'une cellule
Réponses
12
Affichages
2 K
arochab
A
Y
  • Question
Recherche multicritères VBA
Réponses
8
Affichages
2 K
Ynwa_57
Y
M
  • Question
Erreur macro avec filtre par date
Réponses
13
Affichages
2 K
martial58
M
C
  • Question
mettre en place un message d'erreur dans le cas d'une création de feuille.
Réponses
1
Affichages
1 K
ERIC S
ERIC S
L
  • Question
Concaténation pied de page vba excel
Réponses
3
Affichages
1 K
Pierrot93
Pierrot93
R
  • Question
Format date dans Autofilter
Réponses
2
Affichages
1 K
roulax
R
M
  • Question
Inputbox format date (besoin d'un 2ème regard)
Réponses
8
Affichages
2 K
La Haine
L

Membres actuellement en ligne

3 membres et 58 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 595
Messages
2 090 094
Membres
104 374
dernier inscrit
cheick.coulibaly@dcsmali.