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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
| Private Sub UserForm_Initialize()
'Accueil
Sheets("Accueil").Activate
ActiveSheet.Protect Sheets("Reglages").Range("I9").Value
'Initialisation de l'userform "Mise en forme"
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayFullScreen = True
Application.DisplayExcel4Menus = False
Application.DisplayFormulaBar = False
Application.DisplayStatusBar = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
ActiveWindow.DisplayHeadings = False
'Cacher les onglets
ActiveWindow.DisplayWorkbookTabs = False
'Masquer le bouton "Croix de fermeture"
Dim hSysMenu As Long
Dim MeHwnd As Long
MeHwnd = FindWindowA(vbNullString, Me.Caption)
If MeHwnd > 0 Then
hSysMenu = GetSystemMenu(MeHwnd, False)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
Else
MsgBox "Handle de " & Me.Caption & " Introuvable", vbCritical
End If
'---------------------------------------------------------------Import de la BDD depuis le chemin indiqué-----------------------------------------------------------------
'Initialisation des variables de traitements
Dim repertoire As String, Fichier As String
Dim DateModifFichier As Date
repertoire = Workbooks(1).Sheets("Reglages").Range("I12").Value
'Si il n'y a pas de fichier dans le répertoire alors ...
If repertoire = "" Then
'erreur1004:
MsgBox "La base de données est introuvable." & Chr(10) & "Merci d'entrer à nouveau le chemin de destination de la base de données depuis le menu 'Réglages' (Roue crantée)", vbCritical
GoTo ici
End If
'Ouverture du fichier
Workbooks.Open (repertoire), ReadOnly:=True
'----------------------------Récupération du range de la BDD permettant de copier-coller intégralement les données externes :----------------------------------------------
'Suppression de la BDD du formulaire
Workbooks(1).Sheets("BDD").Cells.Clear
For Each Pic In Workbooks(1).Sheets("BDD").Pictures
Pic.Delete
Next Pic
'i correspond à la dernière ligne de la colonne A de la BDD
i = Workbooks(2).Sheets("BDD").Range("A" & Rows.Count).End(xlUp).Row
'j correspond à la dernière colonne de la BDD
nbcol = Workbooks(2).Sheets("BDD").Cells(1, Cells.Columns.Count).End(xlToLeft).Column 'on récupère le numéro de la dernière colonne
j = Split(Cells(1, nbcol).Address, "$")(1) 'on convertir le numéro en "lettre Colonne"
'k correspond à la dernière ligne de la dernière colonne de la BDD
k = Workbooks(2).Sheets("BDD").Range(j & Rows.Count).End(xlUp).Row 'On recupère le numéro de la dernière ligne (dernière colonne)
'Voici le copier/coller des données du formulaire en direction de la BDD
Workbooks(1).Sheets("BDD").Range("A" & i & ":" & j & k).Value = Workbooks(2).Sheets("BDD").Range("A" & i & ":" & j & k).Value
'Copier/coller des données de la BDD
Workbooks(2).Sheets("BDD").Activate
Cells.Select
Selection.Copy
Workbooks(1).Sheets("BDD").Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone
ActiveSheet.Paste
'ton code que j'ai testé ici :
For Each Img In Workbooks(1).Sheets("BDD").Shapes
Img.LockAspectRatio = msoFalse
Workbooks(1).Sheets("BDD").Columns("C:C").ColumnWidth = 83
For Each cel In Workbooks(1).Sheets("BDD").Range("C3:C" & i).Rows
cel.RowHeight = 146.25
With Img
.Left = cel.Left
.Top = cel.Top
.Width = cel.Width
.Height = cel.Height
End With
Next cel
Next Img
Application.CutCopyMode = False
'Copier/coller des en-têtes de la BDD
Workbooks(2).Sheets("BDD").Activate
Rows("1:2").Select
Selection.Copy
Workbooks(1).Sheets("BDD").Activate
Rows("1:2").Select
ActiveSheet.Paste
'Mise en forme des cellules (mode tableau)
Cells.Select
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'Mise en forme (Centrage des lignes et colonnes)
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Workbooks(2).Close (False)
ici:
' //Combobox "Ressource"
Dim l1 As Long 'déclare la variable l1 (Ligne de Fin)
Dim u As String
Dim r As String
Dim s As String
Sheets("BDD").Select
l1 = Range("A65536").End(xlUp).Row 'définit la variable l1
ComboBox1.Clear 'vide la ComboBox1
For Each Col In Sheets("BDD").Range("A:A")
u = 0
If Col = "Article" Then
r = u
's = Split(Cells(0, r).Address, "$")
End If
Next
u = u + 1
'remplit la ComboBox
For Each cel In Range("A2:A" & l1) 'boucle sur toutes les cellule de A2 à A_l1
'condition : si la cellule n'est pas vide ajoute son contenu à la ComboBox1
If cel.Value <> "" Then ComboBox1.AddItem cel.Value
Next cel 'prochaine cellule
' //Combobox "Instruments"
Dim l3 As Long 'déclare la variable l1 (Ligne de Fin)
Sheets("Reglages").Select
l3 = Range("B65536").End(xlUp).Row 'définit la variable l2
ComboBox3.Clear 'vide la ComboBox1
'remplit la ComboBox
For Each cel In Range("B2:B" & l3) 'boucle sur toutes les cellule de A2 à A_l1
'condition : si la cellule n'est pas vide ajoute son contenu à la ComboBox1
If cel.Value <> "" Then ComboBox3.AddItem cel.Value
Next cel 'prochaine cellule
Sheets("Accueil").Activate
'Update du Screen (Mise en forme - centrage de l'affichage)
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Range("A1:K40").Select 'ici tu selectionne la plage que tu veux elle sera zommée pour remplir tout l'ecran quelque se soit la resolution de ton ecran
ActiveWindow.Zoom = True
Range("G9").Select
Sheets("Accueil").EnableSelection = xlLockedCells
Application.ScreenUpdating = True
End Sub |
Partager