Remplir un tableau en fonction de plage de disponibilité

[MAZETTE]

Bonjour à tous,

Je rencontre un petit probléme de remplissage de tableau.

Sur mon classeur,j'ai deux feuille dont l'une s'appelle "Perso"...

Cette feuille est composée de nom,jour de semaine,C1,C2,C3,C4 où C1,C2,C3,C4 correspondent a des début de disponibilités horaires et à des fin de disponibilités horaires

Je souhaiterai donc à partir des données se trouvant sur cette feuille remplir "Feuil5" , mais je doit absolument conserver la mise en forme de perso..c'est ce qui me bloque aujourd'hui...sur cette satané formule grrrrrrrrrr!!!!

J'ai effectué quelque recherhce sur le forum et je suis tombé sur ce fil qui pourrait éventuellement correspondre à ma demande sans MFC

https://www.excel-downloads.com/threads/horaire.93015/

Merci à tous pour le coup demain...

 

[PMO2]

Re : Remplir un tableau en fonction de plage de disponibilité

Bonjour,

Voici une solution mais en VBA. Je me suis entièrement basé sur l'exemple que vous avez fourni.
Il est donc IMPERATIF d'en conserver la structure (liste des noms en colonne C et commençant en ligne 12, format des heures "hh:mm", etc).
Pour vous rendre compte, le mieux est de télécharger la pièce jointe.

Copiez le code suivant dans un module Standard

'### Constante du nom de la feuille source - A adapter ###
Const SOURCE As String = "Perso"
'#########################################################

Sub PlanningDisponibilite()
Dim S As Worksheet
Dim R As Range
Dim T()
Dim Heure()
Dim var
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim nbNom&
Dim nbLig&
Dim jour&
Dim JOURS
Dim switch As Boolean
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S = Sheets(SOURCE)
Set R = S.Range(S.Cells(12, 1), S.Cells(S.[c65536].End(xlUp).Row, 33))
var = R
nbNom& = UBound(var, 1)
Set S = Worksheets.Add(after:=Sheets(Sheets.Count))
JOURS = Array("", "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche")
ReDim T(1 To (nbNom& + 1) * 7, 1 To 97)
For jour& = 1 To 7
  cpt& = cpt& + 1
  T(cpt&, 1) = JOURS(jour&)
  For i& = 1 To nbNom&
    cpt& = cpt& + 1
    T(cpt&, 1) = var(i&, 3)
    k& = 0
    For j& = 6 + (4 * (jour& - 1)) To 6 + (4 * (jour& - 1)) + 3
      If IsNumeric(var(i&, j&)) And var(i&, j&) <> "" Then
        k& = k& + 1
        ReDim Preserve Heure(1 To k&)
        Heure(k&) = 24 * var(i&, j&)
        If Heure(k&) < 5 Then Heure(k&) = Heure(k&) + 24
        Heure(k&) = ((Heure(k&) * 4) - 2) - 16
        If k& = 2 Then
          If Heure(2) < Heure(1) Then
            Set R = S.Range(S.Cells(cpt& + 1, Heure(1)), S.Cells(cpt& + 1, 97))
            If Heure(2) > 2 Then
              S.Range(S.Cells(cpt& + 1, 2), S.Cells(cpt& + 1, Heure(2) - 1)).Interior.ColorIndex = 3
            End If
          Else
            Set R = S.Range(S.Cells(cpt& + 1, Heure(1)), S.Cells(cpt& + 1, Heure(2) - 1))
          End If
          If Not switch Then
            R.Interior.ColorIndex = 38
          Else
            R.Interior.ColorIndex = 37
          End If
          k& = 0
          Erase Heure
        End If
      End If
    Next j&
    switch = Not switch
  Next i&
Next jour&
S.Range(S.Cells(2, 1), S.Cells(UBound(T, 1) + 1, 97)) = T
S.Columns("b:cs").ColumnWidth = 1
ReDim T(1 To 1, 1 To 96)
j& = 5
For i& = 1 To 96 Step 4
  If j& > 23 Then j& = 0
  T(1, i&) = j& & ":"
  j& = j& + 1
Next i&
S.Range(S.Cells(1, 2), S.Cells(1, 97)) = T
For i& = 2 To 97 Step 4
  Set R = S.Range(Cells(1, i&), S.Cells(1, i& + 3))
  R.NumberFormat = "hh:mm"
  R.MergeCells = True
  R.HorizontalAlignment = xlLeft
Next i&
Set R = Nothing
nbLig& = S.UsedRange.Rows.Count
For i& = 2 To nbLig& Step nbNom& + 1
  If R Is Nothing Then
    Set R = S.Range("a2")
  Else
    Set R = Application.Union(R, S.Range("a" & i& & ""))
  End If
Next i&
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 6
R.Font.Bold = True
For i& = 2 To 97 Step 4
  Set R = S.Range(S.Cells(1, i&), S.Cells(nbLig&, i& + 3))
  For j& = 7 To 10
    With R.Borders(j&)
      .LineStyle = xlContinuous
      .Weight = xlMedium
    End With
  Next j&
Next i&
With ActiveWindow
  .SplitRow = 1
  .FreezePanes = True
End With
S.[a1].Select
Exit Sub
Erreur:
Application.ScreenUpdating = True
If Err = 9 Then
  MsgBox "La feuille ''" & SOURCE & "'' est introuvable."
Else
  MsgBox "Erreur :" & Err.Number & vbCrLf & Err.Description
End If
End Sub

Il n'y a plus qu'à lancer la macro PlanningDisponibilite
CELA FAIT
1) création d'une nouvelle feuille dans laquelle le planning des heures va apparaître
2) les lignes d'horaires sont colorées alternativement en rose et en bleu pour une meilleure lisibilité
3) la couleur ROUGE est utilisée si la plage horaire est excédentaire de la ligne, par exemple 1:00 à 7:00.
Il est nécessaire de distinguer le dépassement par la couleur rouge car on pourrait confondre les plages horaires suivantes
1:00 à 7:00 avec 5:00 à 7:00 ET 1:00 à 5:00

Cordialement.

PMO
Patrick Morange

 

[MAZETTE]

Re : Remplir un tableau en fonction de plage de disponibilité

Bonjour PMO2 et le Forum...

Epoustouflant...Je ne m'attendait pas du tout à un vba...Je suis scotché...

Bravo...car cela répond bien à la poblèmatique mais en fait ce je recherche c'est plus une soluce sous formule ce qui me permettrait de l'adapter beaucoup plus faciliement à mon projet...

Donc je cherche encore...Merci à toi