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 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
| Private Sub btnGenereSupports_Click()
Dim wbCatalogue As Workbook
Dim wsListe As Worksheet
Dim iCat As Integer
Dim iFeuille As Integer
Dim iInfo As Integer
Dim colonne As String
Dim chemin As String
Dim prefixe As String
Dim version As String
Dim cheminComplet As String
Dim iObjet As Integer
Dim iAttribut As Integer
Dim iCtrle As Integer
Dim iCle As Integer
Dim typeValeur As Integer
Dim valInt As Integer
Dim valStr As String
Dim nbCol As Integer
Dim NoCol As Integer, Cell As Range
Dim NoLig As Long, Derlig As Long, Var As Variant
Dim paramC As Variant
Dim nameC As Variant
Dim nbrC As Integer
Set wsListe = Application.ThisWorkbook.Sheets("Liste")
' récup les valeurs sur la 1ere feuille
chemin = wsListe.Cells(1, 8)
prefixe = wsListe.Cells(2, 8)
iCat = 2
Do While Not IsEmpty(wsListe.Cells(iCat, 1))
' si avancement est renseigné on ne le refait pas
If IsEmpty(wsListe.Cells(iCat, 3)) Then
nomCatalogue = wsListe.Cells(iCat, 1)
version = wsListe.Cells(iCat, 2)
' ouvrir le fichier catalogue
cheminComplet = chemin & "\" & prefixe & nomCatalogue & "_v" & version & ".xlsx"
Set wbCatalogue = Workbooks.Open(cheminComplet)
iFeuille = 1
Do While iFeuille <= wbCatalogue.Sheets.Count
' nom de la feuille
nomSupport = wbCatalogue.Sheets(iFeuille).Name
' ne pas traiter la feuille de suivi
If nomSupport <> "-Suivi-" And Left(nomSupport, 1) <> "#" Then
' supports de saisie
If wbCatalogue.Sheets(iFeuille).Cells(1, 1) = "Info" Then
' ====================================================================================================
' Ajouter les traitements ici
' ====================================================================================================
Derlig = Split(wsListe.UsedRange.Address, "$")(4)
NoCol = 1
'Suppression "d'" et "l'" ET Remplacement espace-->underscore
For NoLig = 1 To Derlig
Var = wsListe.Cells(NoLig, NoCol)
Debug.Print Var
Debug.Print Replace(Var, " ", "_")
Debug.Print Replace(Replace(Var, "d'", ""), "l'", "")
Next
'Set wsListe = Nothing
'Dé-fusion des cellules à droite du tableau
Range("H1").MergeCells = False
'Insertion des colonnes G à T
paramC = Array("format", "clé", "ctrl1", "p11", "p12", "p13", "ctrl21", "p21", "p22", "p23", "ctrl3", "p31", "p32", "p33")
nameC = Array("G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T")
x = 0
nbrC = 7
Do While x <= 14
Range(nameC(x) + "1").Select
Selection.EntireColumn.Insert
Cells(1, nbrC) = paramC(x)
nbrC = nbrC + 1
x = x + 1
Loop
'If underline X dans 8 et 1 dans 13
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A1").Select
For x = 1 To NumRows
Debug.Print ActiveCell.Select
If ActiveCell.Select.Font.Underline = True Then
Range(x, 13) = 1
Range(x, 8) = "X"
End If
Next
'If Obligatoire = O => Ctrl1 = 1
NumRows = Range("A3", Range("A3").End(xlDown)).Rows.Count
Range("A3").Select
For x = 1 To NumRows
If ActiveCell.Select = "O" Then
Range(x, 9) = 1
End If
Next
'If colonne commentaire = "à prendre dans" => créer un ctrl 7 param2=code
NumRows = Range("A4", Range("A4").End(xlDown)).Rows.Count
Range("A4").Select
valStr = ActiveCell.Select.Text
If InStr(1, valStr, "à prendre dans") Then
End If
End If
End If
iFeuille = iFeuille + 1
Loop
' fermer le catalogue en enregistrant
wbCatalogue.Close SaveChanges:=True
wsListe.Cells(iCat, 3) = "fait"
End If
iCat = iCat + 1
Loop
End Sub |
Partager