1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
|
Sub Transfert_Provisoire()
Dim WordApp As Object
Dim WordDoc As Object
Dim TableauWd1 As Word.Table
Dim TableauWd2 As Word.Table
'Dim TableauWd3 As Word.Table
'Dim TableauWd4 As Word.Table
Dim NbTablesWd As Integer
Dim ColonneWd As Integer
Dim CompteurEleve As Long
Dim PremiereLigneTableau As Long
Dim DerniereLigneTableau As Long
Dim ShEleves As Worksheet
Dim AireEleve As Range
Dim CelluleEleve As Range
Dim SignetEnCours As Bookmark
Set ShEleves = Worksheets("Résultat") 'La feuille lue dans le classeur Excel
With ShEleves
PremiereLigneTableau = 2
DerniereLigneTableau = .Cells(.Rows.Count, 2).End(xlUp).Row
If DerniereLigneTableau < PremiereLigneTableau Then
MsgBox "Aucun élève dans le tableau, fin de programme !", vbCritical
Exit Sub
End If
Set AireEleve = .Range(.Cells(PremiereLigneTableau, 3), .Cells(DerniereLigneTableau, 3))
Set WordApp = CreateObject("word.application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(ThisWorkbook.Path & "\Presences_A3_2021.docx")
If WordDoc.tables.Count < 1 Then
MsgBox "Le document Word ne contient pas de tableaux, fin de programme !", vbCritical
Else
With WordDoc
Set TableauWd1 = .tables(1)
Set TableauWd2 = .tables(2)
'Set TableauWd3 = .tables(3)
' Set TableauWd4 = .tables(4)
End With
End If
CompteurEleve = 0
For Each CelluleEleve In AireEleve
Select Case CompteurEleve
Case Is < 30
With TableauWd1
For ColonneWd = 2 To 8
.Cell(CompteurEleve + 3, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
Next ColonneWd
End With
'With TableauWd2
' .Cell(CompteurEleve + 3, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8) & " " & CelluleEleve.Offset(0, 9)
' End With
Case Else
With TableauWd2
For ColonneWd = 2 To 8
.Cell(CompteurEleve + 3 - 30, ColonneWd).Range.Text = CelluleEleve.Offset(0, ColonneWd - 2)
Next ColonneWd
End With
'With TableauWd4
'.Cell(CompteurEleve + 3 - 30, 2).Range.Text = CelluleEleve.Offset(0, 7) & " " & CelluleEleve.Offset(0, 8) & " " & CelluleEleve.Offset(0, 9)
' End With
End Select
CompteurEleve = CompteurEleve + 1
Next CelluleEleve
' Suppression des pages 3 et 4. Le signet Pages3Et4 va de la ligne suivant le tableau 2 jusqu'à la fin du document.
If CompteurEleve < 31 Then
For Each SignetEnCours In WordDoc.Bookmarks
With SignetEnCours
If .Name = "Pages3Et4" Then .Range.Delete
End With
Next SignetEnCours
End If
End With
Set TableauWd1 = Nothing
Set TableauWd2 = Nothing
'Set TableauWd3 = Nothing
'Set TableauWd4 = Nothing
Set AireEleve = Nothing
Set ShEleves = Nothing
With WordDoc
Résult = InputBox("Nom de la Sauvegarde du Fichier Word ?", "Titre")
.SaveAs2 Filename:=ThisWorkbook.Path & "\" & Résult & ".docx", FileFormat:=wdFormatXMLDocument, LockComments:=False, _
Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
'.Close
End With
WordApp.Visible = True
WordApp.Activate
Set WordDoc = Nothing
Set WordApp = Nothing
'MsgBox "Fin du transfert !", vbInformation
End Sub |
Partager