Opslaan als xlxs zonder formules

Status
Niet open voor verdere reacties.
A

akad9

Gebruiker
Lid geworden
11 jun 2010
Berichten
18
Hallo,

Ik een command gemaakt op een button die mijn sheet opslaat als xlsx-bestand. Zodra ik deze opgeslagen xlsx bestand open, komen er formules in die verwijzen naar een ander sheet en daardoor dus deze getallen niet goed weergegeven zijn. Deze sheet moet opgeslagen worden als xlsx zonder formules.

Hieronder een voorbeeld van mijn code.

Code: 
Private Sub opslaan_Click()    
For Each ws In Worksheets(Array("Factuur"))
        SheetName = ws.Name
        ws.Copy
            
            With ActiveWorkbook

                    .SaveAs Filename:=ThisWorkbook.Path & "\" & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx"
                    .Close SaveChanges:=True
            End With
Next ws
   End Sub
 
Laatst bewerkt:
Laatst bewerkt:
Gaat ook niet lukken zo; een workbook opslaan als xlsx heeft niks te maken met het al dan niet meenemen van formules. Wil je geen formules, dan zul je de kopie om moeten zetten naar waarden. Bijvoorbeeld zo:
Code: 
Dim SheetName As String, Pad As String, NewPad As String

    For Each ws In Worksheets(Array("Factuur"))
        Pad = ThisWorkbook.Path & Application.PathSeparator
        SheetName = ws.Name
        ws.Copy
        Set NewWb = Workbooks.Add(xlWBATWorksheet)
        With NewWb.Sheets(1)
            NewPad = Pad & Application.PathSeparator & ws.Name
            .Name = SheetName
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
            Application.CutCopyMode = False
            Rows("1:1").Font.Bold = True
            .Columns("A:O").EntireColumn.AutoFit
            .Cells(2, 1).Select
           With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
            End With
            ActiveWindow.FreezePanes = True
            With ActiveWorkbook
                If Dir(Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx") <> "" Then _
                    Kill Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx"
                .SaveAs FileName:=Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            End With
            NewWb.Close SaveChanges:=True
    Next ws
 
OctaFish zei:
Gaat ook niet lukken zo; een workbook opslaan als xlsx heeft niks te maken met het al dan niet meenemen van formules. Wil je geen formules, dan zul je de kopie om moeten zetten naar waarden. Bijvoorbeeld zo:
Code: 
Dim SheetName As String, Pad As String, NewPad As String

    For Each ws In Worksheets(Array("Factuur"))
        Pad = ThisWorkbook.Path & Application.PathSeparator
        SheetName = ws.Name
        ws.Copy
        Set NewWb = Workbooks.Add(xlWBATWorksheet)
        With NewWb.Sheets(1)
            NewPad = Pad & Application.PathSeparator & ws.Name
            .Name = SheetName
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
            Application.CutCopyMode = False
            Rows("1:1").Font.Bold = True
            .Columns("A:O").EntireColumn.AutoFit
            .Cells(2, 1).Select
           With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
            End With
            ActiveWindow.FreezePanes = True
            With ActiveWorkbook
                If Dir(Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx") <> "" Then _
                    Kill Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx"
                .SaveAs FileName:=Pad & Application.PathSeparator & Blad1.Range("S8").Value & (" ") & Blad1.Range("P8").Value & (" ") & Blad1.Range("Q8").Value & (" - ") & Blad1.Range("N20").Value & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            End With
            NewWb.Close SaveChanges:=True
    Next ws
Klik om te vergroten...

Ik heb nog een End With toegevoegd en:
"Methode PasteSpecial van klasse Range is mislukt" krijg ik als melding en dan wordt " .Cells(1).PasteSpecial Paste:=8" geel.
 
Sla je bestand op met SaveCopyAs.
Open dan dat nieuwe bestand, vervang de formules door hun waarden, sla het bestand op als document zonder macro's en verwijder het door SaveCopyAs gemaakte bestand.
 
En doe ons een lol, en quoot geen nodeloze berichten. Zou je na 10 jaar toch moeten weten :).
 
Uitgebreid voorbeeldje voor je gemaakt met wat ik zei in #6:
Code: 
Sub CommandButton1_Click()
    Dim RSH As Worksheet
    Dim SHT As Worksheet
    Dim TWB As Workbook
    Dim FSO As Object

    Dim bld As String
    Dim pad As String
    Dim doc As String
    Dim tmp As String
    
    [COLOR="#008000"]'Deze drie vervangen door wat van toepassing is[/COLOR]
    pad = ThisWorkbook.Path
    doc = "Kopietje.xlsx"
    bld = "Blad1"
    [COLOR="#008000"]'-----------------------------------------------[/COLOR]
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tmp = Environ("tmp") & "\" & Replace(FSO.GetTempName, ".tmp", ".xlsm")
    ThisWorkbook.SaveCopyAs tmp
        
    Application.ScreenUpdating = False
    Set TWB = Workbooks.Open(tmp)
    Set SHT = TWB.Sheets(bld)
    With SHT.UsedRange
        .Value = .Value
    End With
    
    Application.DisplayAlerts = False
    For Each RSH In TWB.Sheets
        If RSH.Name <> bld Then
            RSH.Delete
        End If
    Next RSH
    
    TWB.SaveAs pad & "\" & doc, 51
    TWB.Close
    Kill tmp
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set RSH = Nothing
    Set SHT = Nothing
    Set TWB = Nothing
    Set FSO = Nothing
End Sub
 
Laatst bewerkt:
Perfect! Jouw code heeft geholpen Edmoor! Ontzettend bedankt.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan