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
| Option Explicit
Sub Onglet_auto()
'
Dim wsh As Worksheet 'feuille
Dim images$ 'dossier des images
Dim commune$ 'commune
Dim n°L& 'numéro de ligne
Dim d°L& 'derniere ligne
Set wsh = Worksheets("SYNTHESE")
d°L = wsh.Cells(Rows.Count, "A").End(xlUp).Row
images = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
For n°L = d°L To 2 Step -1
commune = wsh.Cells(n°L, "A").Value
' suppression onglet commune preexistant
On Error Resume Next
Application.DisplayAlerts = False
Sheets(commune).Delete
Application.DisplayAlerts = True
On Error GoTo 0
' copie de l'onglet modèle
Worksheets("feuil1").Copy before:=Worksheets(1)
With ActiveSheet
.Name = commune
' écriture des données
.Range("B3").Formula = commune
.Range("B4").Formula = wsh.Cells(n°L, "B").Value 'intervenant
.Range("D8").Formula = wsh.Cells(n°L, "C").Value 'Localisation_X
.Range("D9").Formula = wsh.Cells(n°L, "D").Value 'Localisation_Y
.Range("F4").Formula = wsh.Cells(n°L, "E").Value 'Date_visite
.Range("A24").Formula = wsh.Cells(n°L, "F").Value 'Commentaire
Call Effacer_images(wsh)
Call Inserer_image(wsh.Cells(n°L, "G").Text, images, .Range("B15").MergeArea)
Call Inserer_image(wsh.Cells(n°L, "H").Text, images, .Range("F15").MergeArea)
End With
Next n°L
wsh.Move before:=Worksheets(1)
'Call Inserer_images
Application.ScreenUpdating = True
End Sub
Sub Effacer_images(Optional feuille As Worksheet)
' Supprime toutes les images d'un feuille de calcul
' Arguments : feuille [in] Feuille de calcul concernée
'
Dim shp As Excel.Shape
Dim scr As Boolean
If feuille Is Nothing Then Set feuille = ActiveSheet
scr = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each shp In feuille.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp
Application.ScreenUpdating = scr
End Sub
Private Sub Inserer_image(nomImage$, repImages$, celCible As Range)
' Insère une image depuis un fichier image jpeg vers une cellule
' Arguments : nomImage [in] nom de l'image jpeg (avec ou sans extension)
' repImages [in] Répertoire contenant les images
' celCible [in] Cellule recevant l'image
'
Dim shr As Excel.ShapeRange
If Dir(repImages & nomImage & ".jpg") <> "" Then nomImage = nomImage & ".jpg"
If Dir(repImages & nomImage & ".jpeg") <> "" Then nomImage = nomImage & ".jpeg"
If Dir(repImages & nomImage) = "" Then
MsgBox "L'image " & nomImage & " n'existe pas dans le dossier :" & vbCrLf & repImages
Else
Set shr = celCible.Parent.Pictures.Insert(repImages & nomImage).ShapeRange
With shr
.Name = Mid(nomImage, 1, InStrRev(nomImage, ".") - 1)
.LockAspectRatio = msoFalse
.Left = celCible.Left
.Top = celCible.Top
.Width = celCible.Width
.Height = celCible.Height
End With
End If
End Sub |
Partager