Probleem bij kolombreedten met opslaan mbv VBA

[NuMan]

Hallo,
Ik heb zelf niet genoeg ervaring met VBA.

Ik wil graag een kopie maken van een werkblad.

Bij kopieren moeten volgende data gekopieerd worden:
1. waarden ipv formules
2. opmaak
3. kolombreedten

Ik heb hiervoor een macro gevonden.
Alles lukt wel, maar de kolombreedten niet.
Zie ook test bijlage.

Wie kan mij helpen?

Alvast bedankt.

 

[jpvs]

Je macro staat verkeerd : hij staat in ThisWorkbook en moet in een Module staan?
Heb het verbeterd, probeer nu nog eens ?
Bij mij werkt het perfect.

Pierre

Voor meer uitleg zie eens op deze site :
http://users.pandora.be/ingrid/excel/

Macro's - Functies - VBA
Macro's of functies kopiëren
Macro's starten met events (Ber Visser)


Pierre

 

[NuMan]

Macro werkt opzicht prima. Alleen nog steeds problemen bij kolombreedten. De kolombreedten kan ik niet mee kopieren.
Alvast bedankt.

 

[jpvs]

Een tip misschien :
in de macro staat deze zin :
Set r = r.Offset(-r.Row + 1, -r.Column + 1).Resize(r.Rows.Count + r.Row - 1, r.Columns.Count + r.Column - 1)

Zet hier voor eens een accent (') krijgt nu een groen kleur, zo dat het een tekstregel word en voer de macro nog eens uit???

Pierre

 

[NuMan]

Dat is het nu gelukt. Ik heb het onderstaande gedeelte toevoegd. Maar tot nu toe heb ik altijd fout melding gehad. Nu niet meer. Ik zou echt niet weten wat het verschil is met vorige keer. Toch bedankt. Alleen nog op mijn werk uittesten met Excel 2000.


=====================================
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
======================================
complete macro:

Sub KopierenEnPlakken()
'
' KopierenEnPlakken Macro
' De macro is opgenomen op 27-04-2004 door Temp
'
'
Dim wsBestaand As Worksheet
Dim wbNieuw As Workbook
Dim r As Range
Dim AlsFiguur As Boolean

AlsFiguur = False
'Link naar de bestaande data
On Error GoTo NietMogelijk
Set wsBestaand = ActiveSheet
'Nieuwe werkmap
Set wbNieuw = Workbooks.Add

'Kopieren
Set r = wsBestaand.UsedRange
Set r = r.Offset(-r.Row + 1, -r.Column + 1).Resize(r.Rows.Count + r.Row - 1, r.Columns.Count + r.Column - 1)
r.Copy

If AlsFiguur Then
'Als figuur
wbNieuw.ActiveSheet.Pictures.Paste
Else
'Als data
wbNieuw.ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
End If

Application.CutCopyMode = False

Exit Sub
NietMogelijk:
MsgBox "Actieve blad is geen werkblad"
End Sub