Opgelost VBA aanpassen kopie van selectie maken

[Senso]

Ik heb een groot document (privéinfo) dat onwerkbaar is geworden.
Daarom wil ik het splitsen. Echter de rijhoogte en kolombreedtes worden bij het opslaan niet goed overgenomen. Als ik dan 20 nieuwe documenten heb en moet alles handmatig aanpassen is niet erg prettig. Mogelijk is de VBA nog te verbeteren.

Dus ik selecteer eerst een gebied in het oude document, schakel de macro in en geef een nieuwe naam aan het op te slaan document. Nu zie ik ook dat de marges niet worden aangepast.

Kan ook dat er een macro moet komen die de kolombreedtes en marges aanpast.

A = 4
B = 4
C = 4
D = 6,14
E = 1,57
F = 72,71

Marges
L = 1,1
R = 0,5
B = 1,4
O = 0,9

Office 2007 H&S

Sub ExportRangetoExcel()
'Updateby Extendoffice
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim address As String
Dim defult As Integer
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
defult = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = defult
WorkRng.Copy
wb.Worksheets(1).Paste
address = Replace(WorkRng.address, ":", "-")
address = Replace(address, "$", "")
address = Replace(address, ".", "")
saveFile = Application.GetSaveAsFilename(InitialFileName:=address, fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
wb.SaveAs Filename:=saveFile
wb.Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Warme bakkertje]

Ipv Paste te gebruiken kijk eens bij PasteSpecial welke mogelijkheden je allemaal hebt.

PS: het is niet defult maar Default

 

[Senso]

Ik heb daar geen verstand van en dat gaat mij dan weer uren kosten om te kijken hoe dat zit, en dan werkt het toch niet. Defult aangepast. Vreemd dat die fout er 2 x in staat.

 

[snb]

Gebruik

Sub M_snb()
    Sheets("Sheet1").Copy
End Sub.

om een nieuw werkboek van dit werkblad te maken.
Daarna kun je daaruit verwijderen wat je niet nodig hebt

 

[Senso]

saveFile = Application.GetSaveAsFilename(InitialFileName:=address, fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")

Het meeste is gelukt.
Wil iemand dit aanpassen, want ik wil het opslaan als xlsm (werkbook met macro's).
Ik heb dit aangepast xlsx naar xlsm maar dan werkt het niet.

Volgens mij gelukt. De eindcode.

Sub ExportRangetoExcel()
'Updateby Extendoffice
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Dim address As String
Dim default As Integer
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
default = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = defult
WorkRng.Copy
wb.Worksheets(1).Paste
address = Replace(WorkRng.address, ":", "-")
address = Replace(address, "$", "")
address = Replace(address, ".", "")
'saveFile = Application.GetSaveAsFilename(InitialFileName:=address, fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
saveFile = Application.GetSaveAsFilename(InitialFileName:=address, fileFilter:="Excel Macro-Enabled Workbook (*.xlsm),*.xlsm")
wb.SaveAs Filename:=saveFile, FileFormat:=52
wb.Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub