werkblad zonder code kopieren, maar wel afbeeldingen

[HWV]

Beste,

Op het forum ben ik de volgende code tegen gekomen die een kopie maakt van het werkblad zonder achterliggende code`s.
Perfect!.
Maar in het werkblad staan ook een afbeelding en selectievakje`s die meegekopieerd moeten worden.
Ik zie niet waar ik het fout doet maar krijg het niet voor elkaar dat dit meegekopieerd wordt in deze code voor de rest van de opmaak gaat het wel goed:

Sub WaardenKopie()
    Dim shB As Worksheet
    Dim shD As Worksheet
    Dim wkbB As Workbook
    Dim wkbD As Workbook
    Dim intSh As Integer
    Dim intCount As Integer
On Error GoTo Err_WaardenKopie
    intSh = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set wkbB = Application.ActiveWorkbook
    Set wkbD = Workbooks.Add
    intCount = wkbB.Sheets.Count
    Application.ScreenUpdating = False
    If intCount > 1 Then
        wkbD.Sheets.Add after:=wkbD.Sheets(1), Count:=intCount - 1
    End If
    For i = 1 To intCount
        Set shB = wkbB.Sheets(i)
        Set shD = wkbD.Sheets(i)
        shD.Name = shB.Name
        shB.Cells.Copy
        shD.Range("A1").PasteSpecial xlPasteFormats
        shD.Range("A1").PasteSpecial xlPasteValues
                shD.Activate
        shD.Range("A1").Select
    Next
    wkbD.Sheets(1).Activate
    
    ActiveWindow.DisplayGridlines = False
    
Exit_WaardenKopie:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.SheetsInNewWorkbook = intSh
    Exit Sub
Err_WaardenKopie:
    MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation, "WaardenKopie"
    Resume Exit_WaardenKopie
End Sub

 

[VenA]

Best wel onbegrijpelijke code die je gevonden hebt.

Bedoel je zoiets?

Sub VenA()
If Sheets.Count > 1 Then
    For j = 2 To Sheets.Count
        c00 = c00 & "|" & Sheets(j).Name
    Next j
        Sheets(Split(Mid(c00, 2), "|")).Copy
    For Each sh In Sheets
        sh.UsedRange = sh.UsedRange.Value
    Next sh
End If
End Sub

 

[HWV]

Maar ook de acherliggende code is gekopieerd!

Beste VenA

Bedankt voor jou reactie.
Ik heb de code verwerkt maar dan gaat de code achter de sheets ook mee.
Ik heb een voorbeeldje gemaakt zodat je kan zien hoe mijn bestand er ongeveer uit ziet
Bij sheet 1 heb ik een test script neergezet, die mag niet mee naar de kopie
De afbeeldingen zouden wel gekopieerd moeten worden naar het niet blad

Bekijk bijlage Copie met afbeelding zonder code.xlsm

 

[VenA]

En wat is het probleem? Er staat geen code achter sheets(2) en sheets(3). Ik neem aan dat je met het nieuw aangemaakte bestand ook nog wat slims gaat doen. Zoals opslaan?

Sheets(1) moet toch niet mee gekopieerd worden?

If intCount > 1 Then

 

[snb]

Sub M_snb()
   Application.DisplayAlerts = False
    
    Sheets("offertebon").Copy
    With ActiveWorkbook
      .SaveAs "G:\OF\offertebon.xlsx", 51
      .Close 0
    End With
    
    Workbooks.Open "G:\OF\offertebon.xlsx"
End Sub

 

[HWV]

Opgelost

Beste,

Bedankt voor de bijdrage, ik heb het voor elkaar gekregen met de code van SNB.

Dank voor de inzet.

HWV