Excel probleem VBA

[erigon]

Hallo Ik heb een workbook met verschillende sheets. De macro hieronder zorgt ervoor dat deze verschillende sheets automatisch kunnen worden opgeslagen als apart workbook. Dit werk ook. Nu heb ik alleen samengevoegde cellen in het initiele bestand. Dit heb ik opgelost met een klein stukje code alleen het probleem is echter dat hij niet alle tekst meekopieert vanuit de cellen. Hij kopieert alleen een x aantal tekens anar het nieuwe workbook.

De code:

Sub Creeer_werkblad_per_sheet()

'Working in 97-2007
    Application.Run "onzichtbaarmaken"

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "\PersoonlijkeData\" & Worksheets("Start").Range("e6") & "\Project rapportages"

    'Copy every visible sheet to a new workbook
            For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
        sh.Copy
        
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
                     .Cells.PasteSpecial xlPasteFormats, Operation:= _
                        xlNone, SkipBlanks:=False, Transpose:=False
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
'celinhoud die samengevoegd moet worden
    Range("C34:Q38").Select
    ActiveWindow.SmallScroll Down:=12
    Range("C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43").Select
    Range("U41").Activate
    ActiveWindow.SmallScroll Down:=24
    Range( _
        "C34:Q38,S34:S38,U34:U38,C41:Q43,S41:S43,U41:U43,C66:Q71,S66:S71,U66:U71,C79:U82,C85:U88" _
        ).Select
    Range("C85").Activate
    With Selection
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    Range("a1").Select
    End With
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & "   " & Range("d2").Formula & "   " & "- " & Range("u3").Formula & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "Je kan de bestanden vinden in:  " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
        Application.Run "zichtbaarmaken"
End Sub