VBA placer rdv dans un fichier planning

[Bens7]

Bonjour a tous !
Voila je suis novice en VBA je cherche a placer un nom dans un planning qui corespond a une date et une heure specifique dans un fichier apeller planning.slm je vous est mis la structure exact de mes fichiers le fichier a ouvrire en premier est dans FICHE/exemple.xlsm

Merci d'avance pour votre aide
PS: J;ai deja chercher sur Google pas trouver et si vous pouvez me mettre le code c'est top !
Merci vraiement c'est super important !

 

[mapomme]

Re : VBA placer rdv dans un fichier planning

Bonjour Bens7,

Un essai dans les fichiers joints. Suivant où sont stockés les fichiers, suivant leurs noms ou noms d'onglet, il faudra modifier les valeurs de quelques constantes.

Le code dans module1 de Planning.xlsm :

Option Explicit

Const FeuillePlanning = "Feuil2"
Const Sec10ieme = 1# / 24 / 60 / 60 / 10

Public Sub Placer_RdV(ByVal alaDate, ByVal alheure, ByVal Nom)
Dim xdate As Range, xRdV As Range, i&

With ThisWorkbook.Sheets(FeuillePlanning)
  'recherche date - dans ligne 2
  Set xdate = .Rows(2).Find(what:=alaDate, LookIn:=xlValues, lookat:=xlWhole)
  If xdate Is Nothing Then
    'date pas trouvée - message et fin
    MsgBox "la date n'a pas été trouvée -> abandon"
    Exit Sub
  Else
    'recherche heure - boucle sur colonne A
    For i = 3 To 26
      If Abs(.Cells(i, "a") - alheure) < Sec10ieme Then Exit For
    Next i
    If i > 26 Then
      'heure pas trouvée - message et fin
      MsgBox "l'heure n'a pas été trouvée -> abandon"
      Exit Sub
    Else
      'heure trouvée - 1ière cellule des 4 possibles
      Set xRdV = .Cells(i, xdate.Column)
      'vérif si disponibilité - parcours des 4 cellueles à partir de xRdV
      For i = 0 To 3
        If IsEmpty(xRdV.Offset(i)) Then Exit For
      Next i
      If i > 3 Then
        'pas de cellule dispo - message et fin
        MsgBox "Plus aucun créneau dispo. à l'heure souhaitée -> abandon "
        Exit Sub
      Else
        'placement du Nom
        xRdV.Offset(i) = Nom
        MsgBox "RdV de : " & Nom & vbLf & "placé le : " & _
          Format(alaDate, "dddd dd mmmm yyyy") & " à " & Format(alheure, "hh:mm")
      End If
    End If
  End If
End With
End Sub

Le code dans module1 du fichier Exemple.xlsm :

Option Explicit

Const CheminPlanning = "C:\FORUM1"
Const Nomplanning = "PLANNING.xlsm"

Sub PrendreRdV()
Dim wbk As Workbook, FichierPlanning$
Application.ScreenUpdating = False
  'vérif fichier planning ouvert. Si non, l'ouvrir
  FichierPlanning = CheminPlanning & IIf(Right(CheminPlanning, 1) = "\", "", "\") & Nomplanning
  On Error Resume Next
    'attibution à l'objet wbk
    Set wbk = Workbooks(Nomplanning)
    If wbk Is Nothing Then
      'le planning n'est pas ouvert, on va l'ouvrir
      Set wbk = Workbooks.Open(FichierPlanning)
      If wbk Is Nothing Then
        'le planning n'était pas ouvert et on n'arrive pas à l'ouvrir
        MsgBox "Le Fichier Planning est introuvable" & vbLf & vbLf _
            & FichierPlanning & vbLf & vbLf & "-> Abandon!"
        Exit Sub
      End If
    End If
  On Error GoTo 0
  
  If Not wbk Is Nothing Then
    'si le Planning est ouvert => placer le RdV
    With ThisWorkbook.ActiveSheet
      'lancer la macro Placer_RdV au sein du fichier planning
      Application.Run "'" & Nomplanning & "'!" & "Placer_RdV", _
          .Cells(3, "b"), .Cells(4, "b"), .Cells(2, "b")
      'fermeture planning
      wbk.Close True
    End With
  End If
'Fin
Application.ScreenUpdating = True
End Sub