Bonjour à tous,
J'ai un petit souci lorsque je veux copier une certaine partie d'une feuille dans un autre classeur en VBA. Voici mon code (il y a plein de trucs inintéressants, j'ai marqué la ligne qui bug). Accessoirement, j'ai aussi un autre souci: je voudrais mettre par défaut le zoom du nouveau classeur à 80 mais ca ne marche pas.
Merci de me dire ce qui ne va pas
FoLKeN
J'ai un petit souci lorsque je veux copier une certaine partie d'une feuille dans un autre classeur en VBA. Voici mon code (il y a plein de trucs inintéressants, j'ai marqué la ligne qui bug). Accessoirement, j'ai aussi un autre souci: je voudrais mettre par défaut le zoom du nouveau classeur à 80 mais ca ne marche pas.
Code:
Sub CreatePlanningOutput()
' Declaration
Dim saveName As String
Dim savePath As String
savePath = Application.ThisWorkbook.Path & "\Outputs\Compact_Training_Plans\"
Dim prefixSaveName As String
prefixSaveName = "Compact Training Plan - "
Dim suffixSaveName As String
suffixSaveName = ".xls"
Dim CurrentRange As Range
' Loop declaration
Dim LoopSheet As Worksheet
' Open an excel workbook
Dim NewWkb As Workbook
Set NewWkb = Application.Workbooks.Add
' In case there is an error
On Error GoTo ErrQuit
' Link to the original workbook sheets
Dim TrainingSheet As Worksheet
Dim SessionsSheet As Worksheet
Dim VirtualSheet As Worksheet
Dim TraineePlanningSheet As Worksheet
Set TrainingSheet = ThisWorkbook.Sheets("Training_Map")
Set SessionsSheet = ThisWorkbook.Sheets("Sessions_Details")
Set VirtualSheet = ThisWorkbook.Sheets("Virtual_Sessions")
Set TraineePlanningSheet = ThisWorkbook.Sheets("Trainees_Full_Planning")
' Allocate the new workbook sheets
Dim NewTrainingSheet As Worksheet
Dim NewSessionsSheet As Worksheet
Dim NewVirtualSheet As Worksheet
Dim NewTraineePlanningSheet As Worksheet
Set NewTrainingSheet = NewWkb.Sheets(1)
NewTrainingSheet.Name = TrainingSheet.Name
Set NewSessionsSheet = NewWkb.Sheets(2)
NewSessionsSheet.Name = SessionsSheet.Name
Set NewVirtualSheet = NewWkb.Sheets(3)
NewVirtualSheet.Name = VirtualSheet.Name
Set NewTraineePlanningSheet = NewWkb.Sheets.Add
NewTraineePlanningSheet.Name = TraineePlanningSheet.Name
' Put the zoom to 80% and remove cell outlines
For Each LoopSheet In NewWkb.Sheets
[COLOR="Red"]LoopSheet.PageSetup.Zoom = 80 ' DOESNT WORK[/COLOR]
LoopSheet.Cells.Interior.PatternColorIndex = xlAutomatic
Next LoopSheet
' Copy the Training_Map table
[COLOR="Red"]TrainingSheet.Range("B8:GW1413").Select 'PB ICI[/COLOR]
Selection.Copy
Set CurrentRange = NewTrainingSheet.Range("B2")
NewTrainingSheet.Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
NewTrainingSheet.Range("B2").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
NewTrainingSheet.Range("B2").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' Copy the sessions_details table
' Copy the virtual session table (if not empty)
' Copy the Trainee_Full_Planning table
' Copy the Instructor_Full_Planning table (?)
' Create the saving name
Dim CurrentDate As String
Dim CurrentTime As String
CurrentDate = CStr(Format(Now, "DD.MM.YY", vbMonday))
CurrentTime = CStr(Format(Now, "HH.MM", vbMonday))
saveName = prefixSaveName & CurrentDate & " at " & CurrentTime & suffixSaveName
If CreateFolder(savePath) Then MsgBox ("Saving in: " & savePath & saveName)
ErrQuit:
' Save & quit
If Err.Number = 0 Then
NewWkb.SaveAs FileName:=savePath & saveName
NewWkb.Close
MsgBox ("Document Created")
Else
NewWkb.Close SaveChanges:=False
MsgBox ("Error while creating the document: " & Err.Description)
End If
Set NewWkb = Nothing
End Sub
Merci de me dire ce qui ne va pas
FoLKeN