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
|
Application.ScreenUpdating = False
Dim haut()
Dim Gauche()
Dim MesGraphes As ChartObject
Dim MesImg As Shape
Dim currentLine As Integer
currentLine = 0
Dim currentTop As Integer
currentTop = 0
Dim i As Variant
For w = 2 To Worksheets.Count
i = Empty
'Copy the cells
Set c = Worksheets(w).Cells.Find(What:="END", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If IsEmpty(c) = False Then
Worksheets(w).Range(Worksheets(w).Cells(1, 1), Worksheets(w).Cells(c.Row, 1)).EntireRow.Copy
Worksheets(1).Cells(currentLine + 1, 1).PasteSpecial Paste:=xlPasteValues
Worksheets(1).Cells(currentLine + 1, 1).PasteSpecial Paste:=xlPasteFormats
'Copy the graphs
For Each MesGraphes In Worksheets(w).ChartObjects
i = i + 1
ReDim Preserve haut(i)
ReDim Preserve Gauche(i)
haut(i) = MesGraphes.Top
Gauche(i) = MesGraphes.Left
MesGraphes.Copy
Worksheets(1).PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
Next
'Set the image at the same position as the graphs
i = 0
For Each MesImg In Worksheets(1).Shapes
If MesImg.AlternativeText <> "done" Then
i = i + 1
MesImg.Top = haut(i) + currentTop
MesImg.Left = Gauche(i)
MesImg.AlternativeText = "done"
End If
Next
currentLine = currentLine + c.Row
currentTop = currentTop + Worksheets(w).Cells(c.Row + 1, 1).Top
Else
MsgBox ("Chaine END non trouvée")
End If
Next
Worksheets(1).Cells.Replace What:="END", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True |
Partager