Bonjour à tous,
Je me permets de venir vers vous pour de l'aide concernant l'impression en PDF d'un groupe des plages de données.
Actuellement, j'ai le code ci-dessous pour extraire certaines plages de données nommées, sélectionné par l'utilisateur de différents onglets via un Userform. Les plages nommés sont ensuite qui sont regroupé dans un nouveau fichier excel. Je souhaiterais la capacité de laisser le choix à l'utilisateur de produire une extraction soit en excel ou en PDF. Et là, j'avoue que mon niveau de VBA n'est pas suffisant!
Pourriez-vous, svp, m'aider à modifier le code afin d'être capable de produire l'extraction finale en PDF à la place d'un fichier excel ? Je mettrais bien 2 boutons de contrôle afin que l'utilisateur final peut choisir le bouton pour excel ou pour PDF.
Je vous remercie d'avance!
Je me permets de venir vers vous pour de l'aide concernant l'impression en PDF d'un groupe des plages de données.
Actuellement, j'ai le code ci-dessous pour extraire certaines plages de données nommées, sélectionné par l'utilisateur de différents onglets via un Userform. Les plages nommés sont ensuite qui sont regroupé dans un nouveau fichier excel. Je souhaiterais la capacité de laisser le choix à l'utilisateur de produire une extraction soit en excel ou en PDF. Et là, j'avoue que mon niveau de VBA n'est pas suffisant!
Pourriez-vous, svp, m'aider à modifier le code afin d'être capable de produire l'extraction finale en PDF à la place d'un fichier excel ? Je mettrais bien 2 boutons de contrôle afin que l'utilisateur final peut choisir le bouton pour excel ou pour PDF.
Je vous remercie d'avance!
VB:
Sub ExportNamedRangesToNewWorkbook()
Dim selectedRanges As Collection
Dim newWB As Workbook
Dim ctrlSheet As Worksheet
Dim i As Integer
Dim destSheet As Worksheet
Dim cell As Range
Dim rngName As String
Dim UserForm As UserForm1
Dim j As Integer
Dim shape As shape
Dim ws As Worksheet
Dim rngTopLeft As Range
Dim newShape As shape
Dim rngAddress As String
' Show the UserForm to select ranges
Set UserForm = New UserForm1
UserForm.Show
' Collect selected named ranges
Set selectedRanges = New Collection
With UserForm.lstRanges
For j = 0 To .ListCount - 1
If .Selected(j) Then
selectedRanges.Add .List(j)
End If
Next j
End With
' Unload the UserForm
Unload UserForm
' Exit if no ranges are selected
If selectedRanges.Count = 0 Then
MsgBox "No named ranges selected.", vbInformation, "Export Aborted"
Exit Sub
End If
' Create new workbook
Set newWB = Workbooks.Add
' Add a control sheet in the new workbook
Set ctrlSheet = newWB.Sheets(1)
ctrlSheet.Name = "Menu"
ctrlSheet.Cells(1, 1).Value = "Named Ranges Overview"
ctrlSheet.Cells(1, 1).Font.Bold = True
' Loop through selected named ranges
For i = 1 To selectedRanges.Count
' Get the named range
rngName = selectedRanges(i)
' Get the named range and resolve its reference
On Error Resume Next
rngAddress = Replace(ThisWorkbook.Names(rngName).refersTo, "=", "")
Set cell = Nothing
Set cell = ThisWorkbook.Sheets(WorksheetNameFromRefersTo(rngAddress)).Range(RangeAddressFromRefersTo(rngAddress))
On Error GoTo 0
' Skip invalid ranges
If cell Is Nothing Then
MsgBox "Skipping invalid named range: " & rngName, vbExclamation, "Error"
GoTo NextRange
End If
' Add a new sheet for each named range
Set destSheet = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count))
destSheet.Name = rngName
' Copy values and formatting
cell.Copy
destSheet.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
destSheet.Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Adjust column width
destSheet.Columns("A:Z").AutoFit
' Add hyperlink in control sheet
With ctrlSheet
.Hyperlinks.Add Anchor:=.Cells(i + 1, 1), Address:="", SubAddress:= _
"'" & destSheet.Name & "'!A1", TextToDisplay:=rngName
End With
' Add a visible hyperlink back to the Menu sheet in cell K1 on the new sheet
destSheet.Range("K1").Value = "Back to Menu"
destSheet.Hyperlinks.Add Anchor:=destSheet.Range("K1"), Address:="", SubAddress:="'Menu'!A1", TextToDisplay:="Back to Menu"
destSheet.Range("K1").Font.Underline = xlUnderlineStyleSingle
destSheet.Range("K1").Font.Color = RGB(0, 0, 255) ' Blue color for visibility
' Loop through all shapes in the original worksheet (to extract logos)
Set ws = ThisWorkbook.Sheets(cell.Parent.Name)
For Each shape In ws.Shapes
' Check if the shape is within the named range bounds
If Not Intersect(shape.TopLeftCell, cell) Is Nothing Then
' Copy the shape (logo)
shape.Copy
' Paste the shape into the new sheet at the same relative position
Set rngTopLeft = destSheet.Range("A1") ' Start position to paste the logo
destSheet.Paste
' Get the newly pasted shape and adjust its position if needed
Set newShape = destSheet.Shapes(destSheet.Shapes.Count)
newShape.Top = rngTopLeft.Top + shape.Top - cell.Top
newShape.Left = rngTopLeft.Left + shape.Left - cell.Left
End If
Next shape
NextRange:
Next i
' Adjust Control Sheet formatting
ctrlSheet.Columns("A:A").AutoFit
' Notify user of success
MsgBox "Export completed successfully!", vbInformation, "Export Finished"
End Sub
' Helper function: Extract worksheet name from RefersTo address
Function WorksheetNameFromRefersTo(refersTo As String) As String
WorksheetNameFromRefersTo = Split(refersTo, "!")(0)
WorksheetNameFromRefersTo = Replace(WorksheetNameFromRefersTo, "'", "")
End Function
' Helper function: Extract range address from RefersTo address
Function RangeAddressFromRefersTo(refersTo As String) As String
RangeAddressFromRefersTo = Split(refersTo, "!")(1)
End Function
Dernière édition:
