Opslaan van een sheet middels VBA probleem

[allard1]

Geachte kenners,

Voor mijn werk heb ik een rekentool gemaakt waarmee je, hoe kan het ook anders, diverse berekeningen maakt. De uitkomsten die deze berekeningen geven worden weggeschreven naar een uitkomstenblad in de rekentool. Omdat de rekentool deel uitmaakt van een groter geheel (en dus ook wat meer mb's in neemt) kunnen mensen aan het eind het uitkomstenblad afzonderlijk opslaan. Hiervoor heb ik de volgende code geschreven (en gedeeltelijk overgenomen)

Sheets("A").Select
ActiveSheet.Unprotect "pw"
ActiveSheet.Range("B7:K6000").Select
Selection.Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Select
ActiveCell.Offset(0, 0).Select
ActiveCell.PasteSpecial xlPasteAll
'=================================Kopieëren en plakken B===================
Sheets("B").Select
ActiveSheet.Unprotect "pw"
ActiveSheet.Range("A6:N6000").Select
Selection.Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Select
ActiveCell.Offset(2, 0).Select
ActiveCell.PasteSpecial xlPasteAll
'=================================beveiliging op gebruikte sheets weer activeren=======
Sheets("A").Select
ActiveSheet.Protect "356b"
Sheets("B").Select
ActiveSheet.Protect "356b"

'================================Geplakte en gekopieerde gegevens extern opslaan=======
Dim Bedrijfsnaam
Set Bedrijfsnaam = Worksheets("Q").Range("A2")

Dim Naam_rekenaar
Set Naam_rekenaar = Worksheets("Z").Range("b7")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Copy
ChDir "G:\pad van opslaan"
ActiveWorkbook.SaveAs Filename:="G:\pad van opslaan" & " " & Naam_Muteerder & " " & Bedrijfsnaam & " " & Datumtekst, FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

MsgBox "Je gegevens zijn opgeslagen", vbInformation, "Mededeling"
ActiveWorkbook.Close
End If
Sheets("Q").Select
Application.ScreenUpdating = True
End Sub

*Nu zal de code niet de schoonheidsprijs verdienen, maar ik doe mijn best :-S*

De code werkt prima, hij doet alles wat ik wil. Het probleem is alleen dat er een enorm (823kb) bestand ontstaat. Dit terwijl als je er voor kiest een dergelijke sheet zelf te maken deze slechts luttele (20kb) ruimte inneemt. Weten jullie wat ik fout doe? Moet ik andere vba code stopzetten?

Wie o wie heeft er een oplossing voor mij.

Groet,
Allard

 

[Relleboer]

[I]''Kopieëren en plakken[/I]
Sheets("A").Range("B7:K6000").Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Offset(0, 0).PasteSpecial xlPasteAll

Sheets("B").Range("A6:N6000").Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll

[I]''Geplakte en gekopieerde gegevens extern opslaan[/I]
Dim Bedrijfsnaam
Set Bedrijfsnaam = Worksheets("Q").Range("A2")

Dim Naam_rekenaar
Set Naam_rekenaar = Worksheets("Z").Range("b7")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Opslaanblad").Copy
ChDir "G:\pad van opslaan"
ActiveWorkbook.SaveAs Filename:="G:\pad van opslaan" & "" & Naam_Muteerder & " " & Bedrijfsnaam & " " & Datumtekst         

MsgBox "Je gegevens zijn opgeslagen", vbInformation, "Mededeling"
ActiveWorkbook.Close
End If
Sheets("Q").Select
Application.ScreenUpdating = True
End Sub

Ik heb je code even iets ingekort maar kan niet zien waarom je bestand zo groot is zonder dat ik weet hoe je bladen eruit zien. Oja voor alleen gegevens Kopieren hoef je de bladen niet van de beveileging af te halen.

 

[Finch]

Misschien heb je ergens meer cellen in gebruik zonder dat je dat weet, en zonder dat je dat wil. Voer onderstaande code eens uit, en bekijk de resultaten in het licht van hetgeen jij verwacht wat op elke sheet de laatst nodige cel is. Zit hier veel verschil op, dien je rijen en kolommen zonder data te verwijderen.

Sub VeelCellen()

Dim ws As Worksheet
Dim msg As String

msg = vbNullString
For Each ws In Worksheets
    msg = msg & ws.Name & vbTab & ws.Cells.SpecialCells(xlCellTypeLastCell).Address & vbCrLf
Next ws

MsgBox msg, vbInformation + vbOKOnly, "Gebruikte cellen"

End Sub

PS. in deze coderegel

Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll

is die Cstr niet nodig.

 

[Relleboer]

'Kopieëren en plakken
Sheets("A").Range("B7:K6000").Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & (Rows.Count)).End(xlUp).Offset(0, 0).PasteSpecial xlpasteValues

Sheets("B").Range("A6:N6000").Copy
Sheets("Opslaanblad").Select
Sheets("Opslaanblad").Range("A" & (Rows.Count)).End(xlUp).Offset(2, 0).PasteSpecial xlpasteValues

'Geplakte en gekopieerde gegevens extern opslaan
Dim Bedrijfsnaam
Set Bedrijfsnaam = Worksheets("Q").Range("A2")

Dim Naam_rekenaar
Set Naam_rekenaar = Worksheets("Z").Range("b7")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Opslaanblad").Copy
ChDir "G:\pad van opslaan"
ActiveWorkbook.SaveAs Filename:="G:\pad van opslaan" & "" & Naam_Muteerder & " " & Bedrijfsnaam & " " & Datumtekst         

MsgBox "Je gegevens zijn opgeslagen", vbInformation, "Mededeling"
ActiveWorkbook.Close
End If
Sheets("Q").Select
Application.ScreenUpdating = True
End Sub

Denk dat het zo ook wel gaat lukken. ipv alles plakken plakt hij nu alleen de waarden

 

[allard1]

Misschien heb je ergens meer cellen in gebruik zonder dat je dat weet, en zonder dat je dat wil. Voer onderstaande code eens uit, en bekijk de resultaten in het licht van hetgeen jij verwacht wat op elke sheet de laatst nodige cel is. Zit hier veel verschil op, dien je rijen en kolommen zonder data te verwijderen.

Sub VeelCellen()

Dim ws As Worksheet
Dim msg As String

msg = vbNullString
For Each ws In Worksheets
    msg = msg & ws.Name & vbTab & ws.Cells.SpecialCells(xlCellTypeLastCell).Address & vbCrLf
Next ws

MsgBox msg, vbInformation + vbOKOnly, "Gebruikte cellen"

End Sub

PS. in deze coderegel

Sheets("Opslaanblad").Range("A" & CStr(Rows.Count)).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll

is die Cstr niet nodig.

Geachte mensen,

Bedankt voor jullie inspanningen (helemaal omtrent het inkorten van de code, dat zijn van die dingen die ik nog niet beheers) tot zover. Ik heb de code van Finch geprobeerd en deze heeft er maar liefst 20 kb afgesnoept, dus we gaan de goeie kant op. Echter is het bestand nog steeds "gigantisch" ook als ik de nieuwe opslaancode hanteer, blijft het bestand groot.

tot zover de update, ik blijf fröbelen

Groet,
Allard