This is the macro :

Sub Factuur_bewaren()

Dim klant As String
Dim Datum As String
Dim tijd As String
Dim filenaam As String
Dim i As Integer
Dim bk As Workbook, sh As Worksheet

Application.ScreenUpdating = False
    Range("H1").ClearContents
    Range("D13:H13").Select
'naam klant staat in  in vak D13
klant = ActiveSheet.Range("D13").Value
'neemt de dag van vandaag en vomt die om tot een string
Datum = DateValue(Date)
Datum = Format(Date, "yyyy-dd-mm")
'neemt het huidige tijdstip aan elkaar uu-mm-ss
tijd = Format(Time, "hhmmss")
'samenstelling filenaam geen overschrijving mogelijk door tijdsnotatie
filenaam = klant & "-" & Datum & "-" & tijd & ".xls"
'geeft filenaam op het werkblad
ActiveSheet.Range("H1").Value = filenaam
'bewaar file onder de naam
 ChDir "C:\Facturen\"
    Range("B2:O54").Select
    Selection.copy
    Application.DisplayAlerts = False
    Worksheets("Factuur").copy
    Set bk = ActiveWorkbook
    For Each sh In bk.Worksheets
    sh.Cells.copy
    sh.Cells.PasteSpecial xlValues
    Next
    Range("N13").Select

    'alle sheets verwijderen behalve het eerste
    For Each sh In Worksheets
    If sh.Index > 1 Then
    sh.Delete
    End If
    Next
    ActiveWorkbook.SaveAs Filename:= _
         "C:\Facturen\" & filenaam, _
         FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
         ReadOnlyRecommended:=False, CreateBackup:=False
    ' is voor GEEN meldingen te krijgen bij het sluiten.
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close

Application.DisplayAlerts = True
    
    Range("D13").Select
    MsgBox "File is opgeslagen"
End Sub

Is there a way to get the range to a new pic?

Range("B2:054").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

thanks,

P.