creation d'un fichier

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
SoumZoum
Membre fidèle
Membre fidèle
Messages : 349
Inscrit le : 18 novembre 2014
Version d'Excel : Excel 2010 FR

Message par SoumZoum » 24 août 2015, 10:13

Alors, l'idée c'était de voir si la mise en forme te convenait.
Maintenant, on va faire en sorte qu'au changement de la cellule concernée (ta liste déroulante), la feuille se régénère ou qu'une nouvelle feuille soit créée.

Je suis pas mal occupé en ce moment, donc fais quelques tests sur plusieurs années. Le code est stable chez moi, et je n'aurai pas le temps de la simplifier ; donc s'il est stable chez toi aussi, on garde ce bricolage.

Mais à la limite, peut-être que le code de base te conviendrait plus.
J'ai simplement modifié le "bricolage" qui faisait que les jours étaient supprimés. (les trois lignes de boucle en fin de sub)
Essaie le code suivant et reviens vers moi :mrgreen:
Option Explicit
Global varAn%

Sub Proposition()

    Application.ScreenUpdating = False 'On désactive ces fonctionnalités
   Application.Calculation = xlCalculationManual
    
Sheets.Add

Calendrier
Semaines_mois

    Application.ScreenUpdating = True 'On désactive ces fonctionnalités
   Application.Calculation = xlCalculationAutomatic
    
End Sub
Public Sub Semaines_mois()
    
    Dim aCell As Range, oCell As Range
    Dim K As Integer, lR As Integer
    
    
    
    With Range("b1:b1000")
        .NumberFormat = """S""00" 'Format Sxx pour les semaines
       .Font.Bold = True
    End With
    
    lR = Range("c1000").End(xlUp).Row
    
    For K = 2 To lR 'On balaye la colonne C
       If IsDate(Cells(K, 3)) Then
            Set aCell = Cells(K, 3)
                aCell.EntireRow.Insert
                aCell.Offset(-1, -2).EntireRow.Interior.Color = 13082801
                aCell.Offset(-1, -2).Formula = "=PROPER(TEXT(" & aCell.Address & ", ""mmmm aaaa""))"
            K = K + 1
            Set oCell = Cells(K, 3)
            
            If CLng(CDate(Last_Monday(CDate(oCell)))) = CLng(CDate(oCell)) Then oCell.Offset(-1, -1).Formula = "=NO.SEMAINE(" & oCell.Address & ")"
            Exit For
        End If
    Next
    
    While K < lR 'On balaye la colonne C. On utilise While car il faut actualiser l'itération max (lR) en cours de boucle (vu qu'on insère des lignes)
       If IsDate(Cells(K, 3)) Then
            If Month(Cells(K, 3)) <> Month(aCell) Then
                Set aCell = Cells(K, 3)
                aCell.EntireRow.Insert
                aCell.Offset(-1, -2).EntireRow.Interior.Color = 13082801
                aCell.Offset(-1, -2).Formula = "=PROPER(TEXT(" & aCell.Address & ", ""mmmm aaaa""))"
                K = K + 1
            End If
            If SailWeek(CDate(Cells(K, 3))) <> SailWeek(CDate(oCell)) Then
                Cells(K, 3).EntireRow.Insert
                Cells(K, 3).EntireRow.Interior.Color = 16315374
                Cells(K, 3).Offset(0, -1).Formula = "=WEEKNUM(" & oCell.Address & ")"
                Cells(K, 3).Offset(0, 1) = "Semaine du " & CDate(oCell) & " au " & (CDate(oCell - Weekday(oCell, 2) + 7))
                Range(Cells(K, 3).Offset(0, 1), Cells(K, 3).Offset(0, 10)).Merge
                K = K + 1
                Set oCell = Cells(K, 3)
            End If
        End If
        lR = Range("c1000").End(xlUp).Row
        K = K + 1
    Wend 'prochaine itération
   
    Range("A1:A" & lR).Font.Bold = True
    
    Range(Cells(1, 1), Cells(lR, 15)).Copy
    Range(Cells(1, 1), Cells(lR, 15)).PasteSpecial (xlPasteValues)
    Range(Cells(1, 1), Cells(lR, 15)).PasteSpecial (xlPasteFormats)

End Sub

Sub Calendrier()
    
    Dim DS As Date, DSY As Date
    Dim I As Integer, Result As Integer
    
    If varan <> 0 Then
        DS = DateSerial(varan, 1, 1)
        DSY = DateValue("31 décembre " & varan)
        For I = 0 To DSY - DS
            'If Weekday(DS + I, vbMonday) < 6 Then
               Range("c1000").End(xlUp).Offset(1, 0) = DS + I
                With Range("c1000").End(xlUp)
                    .NumberFormat = "m/d/yyyy"
                    .Font.Bold = True
                    .Interior.ThemeColor = xlThemeColorDark1
                    .Interior.TintAndShade = -0.499984740745262
                End With
            'End If
           Next I
            Else: Result = MsgBox("Vous n'avez pas renseigné l'année !" & vbCrLf & "Cliquez sur OK pour renseigner la donnée manquante ou sur annuler pour quitter.", vbOKCancel, "Donnée manquante")
            
            Select Case Result
            Case Is = 2
                Exit Sub
            Case Is = 1
                varan = Val(InputBox("Année ?", "CALENDRIER"))
                Calendrier
            End Select
        End If
        
    End Sub
  
    Function Last_Monday(vDate As Date)
'if today is Monday, then return today's date
       If Weekday(vDate, vbSunday) = 2 Then
            Last_Monday = vDate
        Else
            Last_Monday = vDate - Weekday(vDate, vbSunday) + 2
        End If
    End Function
    
    
' This function was created by Sailesh Kr Mishra (91-9958050139)
' while he was required to pull weekly report using dates of the month
   
    Function SailWeek(dDate1 As Date) As String
        Dim dDate2 As String
        Dim wWeek As Integer
        
'dDate2 is changed to date from String
       
        dDate2 = VBA.CDate(Month(dDate1) & "/01/" & Year(dDate1))
        wWeek = DateDiff("ww", dDate2, dDate1, vbMonday, vbUseSystem) + 1
        
'Return the Week number of the month
'Monday is taken as week starting date, you can change
'it to your desired day as starting date of week
       
        SailWeek = wWeek
    End Function

 
Cordialement,

Toto l'asticot :D
a
aurjemi22
Nouveau venu
Nouveau venu
Messages : 9
Inscrit le : 18 août 2015
Version d'Excel : FR,2010

Message par aurjemi22 » 24 août 2015, 19:50

Ca ne fonctionne pas chez moi quand je renseigne la date et que je valide ça me dit que je n'ai pas renseigné la date

Tant pis c'est pas le plus important je peux le faire en manuel sur la feuille matrice le soucis c'est pour les autres questions la je bloque
Avatar du membre
SoumZoum
Membre fidèle
Membre fidèle
Messages : 349
Inscrit le : 18 novembre 2014
Version d'Excel : Excel 2010 FR

Message par SoumZoum » 24 août 2015, 20:13

J'ai dit qu'on ALLAIT faire en sorte, normal que ça ne marche pas pour le moment :mrgreen:
Cordialement,

Toto l'asticot :D
a
aurjemi22
Nouveau venu
Nouveau venu
Messages : 9
Inscrit le : 18 août 2015
Version d'Excel : FR,2010

Message par aurjemi22 » 25 août 2015, 09:29

ok merci pour ton aide
a
aurjemi22
Nouveau venu
Nouveau venu
Messages : 9
Inscrit le : 18 août 2015
Version d'Excel : FR,2010

Message par aurjemi22 » 26 août 2015, 18:08

Je viens de m'apercevoir qu'il y a un petit soucis sur les semaines
exemple: il me faut la semaine du lundi au dimanche le souci c'est qu'en fin de mois ça va se chevaucher donc

si semaine 1 = lundi 25 au dimanche 31 Janvier2015 pas de soucis c'est Janvier qui s'affiche

mais si semaine 1 = du lundi 28 au dimanche 3 Février la y a soucis car avec ton code la semaine s'arrête le jeudi.

Je ne sais pas si cela est faisable sinon je le ferai manuellement.
Avatar du membre
SoumZoum
Membre fidèle
Membre fidèle
Messages : 349
Inscrit le : 18 novembre 2014
Version d'Excel : Excel 2010 FR

Message par SoumZoum » 26 août 2015, 21:04

Hello,

Oui, les semaines chevauchent les mois, le code suit la dispo calendaire. Qu'est-ce que tu voudrais à la place?
Sinon, par curiosité, de quelle année parles-tu ? :lol: J'ai regardé en 2015 et 2016, mon février ne ressemble pas à ça :mrgreen:

Envoie moi ton fichier (anonymisé) pour qu'on mette en place la régénération au changement de cellule et l'extraction.

EDIT : Ok, je vois ce que tu veux dire concernant les semaines, je viens de remarquer ça. Je te renvoie ça corrigé bientôt

RE-EDIT :

Modifie la fonction SailWeek par celle-là : (et les appels)
Public Function IsoWeekNumber(InDate As Date) As Long
    IsoWeekNumber = DatePart("ww", InDate, vbMonday, vbUseSystem)
End Function
Je crois que rien d'autre n'a changé.
Cordialement,

Toto l'asticot :D
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message