bonjour,
je crée un outil de demande de congés et j'ai crée un formulaire de demande d'absences avec une listview ou on trouve la liste des jours saisie, pour créer le formulaire de demande l'agent doit cliquer sur la première date dans la listeview et la derniere. Ca marche tres bien .
Le probleme c'est que mon code marche pour une seule demande et la on me demande de modifier pour que en un clique cela créer autant de formulaire word que de plages differentes selectionnés. je sais pas si je suis claire prenons par exemple une liste de congés:
12/04/2010 CP
13/04/2010 CP
14/04/2010 CP
15/04/2010 RTT
20/06/2010 CP
21/06/2010 CP
Cela donnere si l'agent sélectionne toutes ces dates dans la listview 3 demades de congés:
_ du 12 au 14/04/2010 pour un CP
_15/04/2010 pour un RTT
_du 20/06/2010 au 21/06/2010 pour un CP
voici mon code
Sub signets()
'On Error GoTo err
10 If Me.ListBox1.Value = "" Then
20 absence = Me.LstAA
30 Else
40 absence = Me.ListBox1
50 End If
Dim i As Integer, y As Integer
Dim LstItem As ListItem
60 On Error Resume Next
70 Set LstItem = ListView1.SelectedItem
80 On Error GoTo 0
90 If LstItem Is Nothing Then
100 MsgBox "Aucune date n'est sélectionnée."
110 Exit Sub
120 Else
' deb = Me.ListView1.SelectedItems(0)
'deb = Me.ListView1.ListItems(1)
'fin = Me.ListView1.ListItems(Me.ListView1.ListItems.Count)
Dim relai As Integer
130 For i = 1 To ListView1.ListItems.Count
140 If ListView1.ListItems(i).Selected = True Then
150 deb = (ListView1.ListItems(i).Text)
160 relai = i + 1
170 Exit For
180 End If
190 Next i
200 absenc = Me.ListView1.ListItems(i).SubItems(1)
210 demi = Me.ListView1.ListItems(i).SubItems(2)
220 For i = relai To ListView1.ListItems.Count
230 If ListView1.ListItems(i).Selected = False Then
'MsgBox (i)
240 fin = (ListView1.ListItems(i - 1).Text)
'MsgBox (fin)
250 Exit For
260 Else
270 i = ListView1.ListItems.Count
280 fin = (ListView1.ListItems(i).Text)
290 End If
300 Next i
'cas ou on selectionne toute les dates
310 If i = 2 Then
'MsgBox (i)
320 fin = (ListView1.ListItems(i - 1).Text)
'MsgBox (fin)
330 End If
'cas ou selectionne une seule date et que c'est la seule de la liste
340 If fin = "00:00:00" Then
'MsgBox (fin)
350 fin = deb
360 End If
'k = ListView1.SelectedItem.Index
'deb = ListView1.ListItems(k).Text
370 Application.ScreenUpdating = False
'recherche agent
380 With ThisWorkbook.Worksheets("agt").Range("a1:a500")
390 Set C = .Find(Me.TextBox1.Value, LookIn:=xlValues)
400 If Not C Is Nothing Then
410 firstAddress = C.Address
420 Do
430 i = C.Row
440 Set C = .FindNext(C)
450 Loop While Not C Is Nothing And C.Address <> firstAddress
460 End If
470 End With
480 num_ligne_agt = i
490 Nom_fichier = Me.TextBox1
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
500 Set wordApp = CreateObject("word.application") 'ouvre une session Word
510 Set wordDoc = wordApp.Documents.Add(Template:=ThisWorkbook.Path & "\formulaire\modele.dotm") 'ouvre le document WordSet WordApp = CreateObject("Word.Application") '-- ouvre une session Word
520 wordApp.Visible = True
'Set WordDoc = WordApp.Documents.Add '-- crée un nouveau document
'WordDoc.SaveAs ch & Nom_fichier & ".docm" '-- enregistre le nouveau doc
530 wordDoc.SaveAs ThisWorkbook.Path & "\formulaire\" & Nom_fichier & ".docx"
540 wordApp.Visible = False 'Word est masqué pendant l'opération
'WordDoc.Bookmarks("SignetDate").Range.Text = Format(Now, "dd/mm/yyyy")
550 Set plage = ThisWorkbook.Sheets(Me.TextBox1.Value).[A2].CurrentRegion
560 Set C = plage.Find(Me.TextBox1, , , xlPart)
570 If Not C Is Nothing Then
580 premier = C.Address
590 i = C.Row
600 End If
610 With Worksheets(nom).Range("b1:b500")
620 Set C = .Find(deb, LookIn:=xlValues)
630 If Not C Is Nothing Then
640 firstAddress = C.Address
650 Do
660 O = C.Row
670 Set C = .FindNext(C)
680 Loop While Not C Is Nothing And C.Address <> firstAddress
690 End If
700 End With
'MsgBox (i)
710 date_tp = ThisWorkbook.Sheets(nom).Range("G" & O).Value
'nom agent
720 wordDoc.Shapes("rectangle 12").TextFrame.TextRange.Text = Me.TextBox1
'date debut
730 wordDoc.Shapes("rectangle 14").TextFrame.TextRange.Text = deb
'date fin
740 wordDoc.Shapes("rectangle 15").TextFrame.TextRange.Text = fin
'absences
750 wordDoc.Shapes("rectangle 13").TextFrame.TextRange.Text = absenc
'demi jr
760 wordDoc.Shapes("rectangle 22").TextFrame.TextRange.Text = demi
'chemin
770 wordDoc.Shapes("rectangle 28").TextFrame.TextRange.Text = ThisWorkbook.Path
780 wordDoc.Shapes("rectangle 34").TextFrame.TextRange.Text = date_tp
790 wordApp.Visible = True 'affiche le document Word
'WordDoc.PrintOut 'Pour imprimer le doc obtenu
800 wordDoc.Close True 'ferme le document word en sauvegardant les données
'wordApp.Quit 'ferme la session Word
' Set wordApp = Nothing
810 If ThisWorkbook.Sheets("agt").Range("AK" & num_ligne_agt).Value = 3 Then
'ouvre une session Word
820 Set wordDoc = wordApp.Documents.Add(Template:=ThisWorkbook.Path & "\formulaire\modele_P.dotm") 'ouvre le document WordSet WordApp = CreateObject("Word.Application") '-- ouvre une session Word
830 wordApp.Visible = True
'Set WordDoc = WordApp.Documents.Add '-- crée un nouveau document
'WordDoc.SaveAs ch & Nom_fichier & ".docm" '-- enregistre le nouveau doc
840 wordDoc.SaveAs ThisWorkbook.Path & "\formulaire\fiche_demande_congé" & Nom_fichier & ".docx"
850 wordApp.Visible = False 'Word est masqué pendant l'opération
'WordDoc.Bookmarks("SignetDate").Range.Text = Format(Now, "dd/mm/yyyy")
860 Set plage = ThisWorkbook.Sheets(Me.TextBox1.Value).[A2].CurrentRegion
870 Set C = plage.Find(Me.TextBox1, , , xlPart)
880 If Not C Is Nothing Then
890 premier = C.Address
900 i = C.Row
910 End If
'valeur = ListView1.ListItems(i).ListSubItems(1).Text
'les signets du document Word sont nommés Signet1 , Signet2 , Signet3
'nom agent
920 wordDoc.Shapes("rectangle 12").TextFrame.TextRange.Text = Me.TextBox1
'date debut
930 wordDoc.Shapes("rectangle 14").TextFrame.TextRange.Text = fin
'date fin
940 wordDoc.Shapes("rectangle 15").TextFrame.TextRange.Text = deb
'absences
950 wordDoc.Shapes("rectangle 13").TextFrame.TextRange.Text = absenc
'directeur
'wordDoc.Shapes("rectangle 34").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("D23").Value
'responsable
' wordDoc.Shapes("rectangle 36").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("E23").Value
'admin
'wordDoc.Shapes("rectangle 37").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("f23").Value
'agent
'wordDoc.Shapes("rectangle 43").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("c23").Value
'ajoute email
960 wordApp.Visible = True 'affiche le document Word
'WordDoc.PrintOut 'Pour imprimer le doc obtenu
970 wordDoc.Close True 'ferme le document word en sauvegardant les données
980 wordApp.Quit 'ferme la session Word
990 Set wordApp = Nothing
1000 End If
1010 End If
1020 Application.ScreenUpdating = True
1030 Exit Sub
err:
1040 MsgBox "Une erreur est survenue, Ligne: " & Erl() & _
vbCrLf & "Numéro d'erreur: " & err.Number & vbCrLf & err.Description
End Sub
si quelqu'un a des pistes merci pour votre aide bonne journée
je crée un outil de demande de congés et j'ai crée un formulaire de demande d'absences avec une listview ou on trouve la liste des jours saisie, pour créer le formulaire de demande l'agent doit cliquer sur la première date dans la listeview et la derniere. Ca marche tres bien .
Le probleme c'est que mon code marche pour une seule demande et la on me demande de modifier pour que en un clique cela créer autant de formulaire word que de plages differentes selectionnés. je sais pas si je suis claire prenons par exemple une liste de congés:
12/04/2010 CP
13/04/2010 CP
14/04/2010 CP
15/04/2010 RTT
20/06/2010 CP
21/06/2010 CP
Cela donnere si l'agent sélectionne toutes ces dates dans la listview 3 demades de congés:
_ du 12 au 14/04/2010 pour un CP
_15/04/2010 pour un RTT
_du 20/06/2010 au 21/06/2010 pour un CP
voici mon code
Sub signets()
'On Error GoTo err
10 If Me.ListBox1.Value = "" Then
20 absence = Me.LstAA
30 Else
40 absence = Me.ListBox1
50 End If
Dim i As Integer, y As Integer
Dim LstItem As ListItem
60 On Error Resume Next
70 Set LstItem = ListView1.SelectedItem
80 On Error GoTo 0
90 If LstItem Is Nothing Then
100 MsgBox "Aucune date n'est sélectionnée."
110 Exit Sub
120 Else
' deb = Me.ListView1.SelectedItems(0)
'deb = Me.ListView1.ListItems(1)
'fin = Me.ListView1.ListItems(Me.ListView1.ListItems.Count)
Dim relai As Integer
130 For i = 1 To ListView1.ListItems.Count
140 If ListView1.ListItems(i).Selected = True Then
150 deb = (ListView1.ListItems(i).Text)
160 relai = i + 1
170 Exit For
180 End If
190 Next i
200 absenc = Me.ListView1.ListItems(i).SubItems(1)
210 demi = Me.ListView1.ListItems(i).SubItems(2)
220 For i = relai To ListView1.ListItems.Count
230 If ListView1.ListItems(i).Selected = False Then
'MsgBox (i)
240 fin = (ListView1.ListItems(i - 1).Text)
'MsgBox (fin)
250 Exit For
260 Else
270 i = ListView1.ListItems.Count
280 fin = (ListView1.ListItems(i).Text)
290 End If
300 Next i
'cas ou on selectionne toute les dates
310 If i = 2 Then
'MsgBox (i)
320 fin = (ListView1.ListItems(i - 1).Text)
'MsgBox (fin)
330 End If
'cas ou selectionne une seule date et que c'est la seule de la liste
340 If fin = "00:00:00" Then
'MsgBox (fin)
350 fin = deb
360 End If
'k = ListView1.SelectedItem.Index
'deb = ListView1.ListItems(k).Text
370 Application.ScreenUpdating = False
'recherche agent
380 With ThisWorkbook.Worksheets("agt").Range("a1:a500")
390 Set C = .Find(Me.TextBox1.Value, LookIn:=xlValues)
400 If Not C Is Nothing Then
410 firstAddress = C.Address
420 Do
430 i = C.Row
440 Set C = .FindNext(C)
450 Loop While Not C Is Nothing And C.Address <> firstAddress
460 End If
470 End With
480 num_ligne_agt = i
490 Nom_fichier = Me.TextBox1
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
500 Set wordApp = CreateObject("word.application") 'ouvre une session Word
510 Set wordDoc = wordApp.Documents.Add(Template:=ThisWorkbook.Path & "\formulaire\modele.dotm") 'ouvre le document WordSet WordApp = CreateObject("Word.Application") '-- ouvre une session Word
520 wordApp.Visible = True
'Set WordDoc = WordApp.Documents.Add '-- crée un nouveau document
'WordDoc.SaveAs ch & Nom_fichier & ".docm" '-- enregistre le nouveau doc
530 wordDoc.SaveAs ThisWorkbook.Path & "\formulaire\" & Nom_fichier & ".docx"
540 wordApp.Visible = False 'Word est masqué pendant l'opération
'WordDoc.Bookmarks("SignetDate").Range.Text = Format(Now, "dd/mm/yyyy")
550 Set plage = ThisWorkbook.Sheets(Me.TextBox1.Value).[A2].CurrentRegion
560 Set C = plage.Find(Me.TextBox1, , , xlPart)
570 If Not C Is Nothing Then
580 premier = C.Address
590 i = C.Row
600 End If
610 With Worksheets(nom).Range("b1:b500")
620 Set C = .Find(deb, LookIn:=xlValues)
630 If Not C Is Nothing Then
640 firstAddress = C.Address
650 Do
660 O = C.Row
670 Set C = .FindNext(C)
680 Loop While Not C Is Nothing And C.Address <> firstAddress
690 End If
700 End With
'MsgBox (i)
710 date_tp = ThisWorkbook.Sheets(nom).Range("G" & O).Value
'nom agent
720 wordDoc.Shapes("rectangle 12").TextFrame.TextRange.Text = Me.TextBox1
'date debut
730 wordDoc.Shapes("rectangle 14").TextFrame.TextRange.Text = deb
'date fin
740 wordDoc.Shapes("rectangle 15").TextFrame.TextRange.Text = fin
'absences
750 wordDoc.Shapes("rectangle 13").TextFrame.TextRange.Text = absenc
'demi jr
760 wordDoc.Shapes("rectangle 22").TextFrame.TextRange.Text = demi
'chemin
770 wordDoc.Shapes("rectangle 28").TextFrame.TextRange.Text = ThisWorkbook.Path
780 wordDoc.Shapes("rectangle 34").TextFrame.TextRange.Text = date_tp
790 wordApp.Visible = True 'affiche le document Word
'WordDoc.PrintOut 'Pour imprimer le doc obtenu
800 wordDoc.Close True 'ferme le document word en sauvegardant les données
'wordApp.Quit 'ferme la session Word
' Set wordApp = Nothing
810 If ThisWorkbook.Sheets("agt").Range("AK" & num_ligne_agt).Value = 3 Then
'ouvre une session Word
820 Set wordDoc = wordApp.Documents.Add(Template:=ThisWorkbook.Path & "\formulaire\modele_P.dotm") 'ouvre le document WordSet WordApp = CreateObject("Word.Application") '-- ouvre une session Word
830 wordApp.Visible = True
'Set WordDoc = WordApp.Documents.Add '-- crée un nouveau document
'WordDoc.SaveAs ch & Nom_fichier & ".docm" '-- enregistre le nouveau doc
840 wordDoc.SaveAs ThisWorkbook.Path & "\formulaire\fiche_demande_congé" & Nom_fichier & ".docx"
850 wordApp.Visible = False 'Word est masqué pendant l'opération
'WordDoc.Bookmarks("SignetDate").Range.Text = Format(Now, "dd/mm/yyyy")
860 Set plage = ThisWorkbook.Sheets(Me.TextBox1.Value).[A2].CurrentRegion
870 Set C = plage.Find(Me.TextBox1, , , xlPart)
880 If Not C Is Nothing Then
890 premier = C.Address
900 i = C.Row
910 End If
'valeur = ListView1.ListItems(i).ListSubItems(1).Text
'les signets du document Word sont nommés Signet1 , Signet2 , Signet3
'nom agent
920 wordDoc.Shapes("rectangle 12").TextFrame.TextRange.Text = Me.TextBox1
'date debut
930 wordDoc.Shapes("rectangle 14").TextFrame.TextRange.Text = fin
'date fin
940 wordDoc.Shapes("rectangle 15").TextFrame.TextRange.Text = deb
'absences
950 wordDoc.Shapes("rectangle 13").TextFrame.TextRange.Text = absenc
'directeur
'wordDoc.Shapes("rectangle 34").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("D23").Value
'responsable
' wordDoc.Shapes("rectangle 36").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("E23").Value
'admin
'wordDoc.Shapes("rectangle 37").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("f23").Value
'agent
'wordDoc.Shapes("rectangle 43").TextFrame.TextRange.Text = ThisWorkbook.Sheets("parametre").Range("c23").Value
'ajoute email
960 wordApp.Visible = True 'affiche le document Word
'WordDoc.PrintOut 'Pour imprimer le doc obtenu
970 wordDoc.Close True 'ferme le document word en sauvegardant les données
980 wordApp.Quit 'ferme la session Word
990 Set wordApp = Nothing
1000 End If
1010 End If
1020 Application.ScreenUpdating = True
1030 Exit Sub
err:
1040 MsgBox "Une erreur est survenue, Ligne: " & Erl() & _
vbCrLf & "Numéro d'erreur: " & err.Number & vbCrLf & err.Description
End Sub
si quelqu'un a des pistes merci pour votre aide bonne journée
