• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Code Inkorten

Status
Niet open voor verdere reacties.
Jack Nouws

Jack Nouws

Terugkerende gebruiker
Lid geworden
16 apr 2008
Berichten
1.396
Hallo

Is het mogelijk om deze macro zodanig in te korten zodat mijn beeldscherm niet van het ene naar het andere bestand op en neer flikkert?

Met vr gr
Jack

Code: 
Private Sub Opslaan_Nu()
Set NieuwBest = Workbooks.Add
    Windows("Green Voorraad.xls").Activate
    Application.Goto Reference:="Print_Area"
    Selection.Copy
    NieuwBest.Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteColumnWidths
    Selection.PasteSpecial Paste:=xlPasteFormats
    ActiveWindow.DisplayGridlines = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.47244094488189)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
    End With
    NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
    ActiveWindow.Close
        Range("A1").Select

End Sub
 
Jack Nouws,

Help dit niet?
Code: 
Application.ScreenUpdating = False
 
Hoornvan zei:
Jack Nouws,

Help dit niet?
Code: 
Application.ScreenUpdating = False
Klik om te vergroten...

Natuurlijk helpt dat maar ik zou graag ook de code iets aangepast hebben zodat het geheel iets sneller en soepeler werkt.

Met vr gr
Jack
 
Zou het dan zo moeten zijn Wigi?

Code: 
Private Sub Opslaan_Nu()
Set NieuwBest = Workbooks.Add
    Windows("Green Voorraad.xls").Application.Reference:="Print_Area".Copy 
    NieuwBest.Range("A1").PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteColumnWidths
    .PasteSpecial Paste:=xlPasteFormats
    ActiveWindow.DisplayGridlines = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.47244094488189)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
    End With
    NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
    ActiveWindow.Close
        Range("A1").Select
End Sub
 
Ik vertrek binnen dit en een half uur op skireis ;)

Heb er geen tijd meer voor sorry.

Ik bekijk het later wel als er nog problemen mee zouden zijn.

Wigi
 
Wigi zei:
Ik vertrek binnen dit en een half uur op skireis ;)

Heb er geen tijd meer voor sorry.

Ik bekijk het later wel als er nog problemen mee zouden zijn.

Wigi
Klik om te vergroten...

Je neemt toch wel je laptop mee hoop ik?
 
Hoornvan zei:
pretige ski vakantie
Klik om te vergroten...

Dit stukje wat in het rood staat komt bij mij ook in het rood te staan in VBA.
Wat wil dat precies zeggen, als de code rood wordt?

Code: 
Private Sub Opslaan_Nu()
Set NieuwBest = Workbooks.Add
    [COLOR="Red"]Windows("Green Voorraad.xls").Application.Reference:="Print_Area".Copy [/COLOR]
    NieuwBest.Range("A1").PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteColumnWidths
    .PasteSpecial Paste:=xlPasteFormats
    ActiveWindow.DisplayGridlines = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.47244094488189)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
    End With
    NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
    ActiveWindow.Close
        Range("A1").Select
End Sub
 
Jack Nouws,
Dit stukje wat in het rood staat komt bij mij ook in het rood te staan in VBA.
Wat wil dat precies zeggen, als de code rood wordt?
Klik om te vergroten...
Dat wil zeggen dat die regel fout is.
Het veranderen van de code was mijn probeersel en ik dacht dat Wigi wel even zou kijken of het goed was.
Misschien dat een ander wel even tijd hiervoor heeft.
 
Jack Nouws,

Misschien is het zo beter?
Code: 
Private Sub Opslaan_Nu()
Set NieuwBest = Workbooks.Add
    Windows("Green Voorraad.xls")
    Application.Reference:="Print_Area".Copy    
    NieuwBest. Range("A1")
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteColumnWidths
    Selection.PasteSpecial Paste:=xlPasteFormats
    ActiveWindow.DisplayGridlines = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.47244094488189)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
    End With
    NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
    ActiveWindow.Close
        Range("A1").Select

End Sub
 
Hoornvan zei:
Jack Nouws,

Misschien is het zo beter?
Code: 
Private Sub Opslaan_Nu()
Set NieuwBest = Workbooks.Add
    Windows("Green Voorraad.xls")
    Application.Reference:="Print_Area".Copy    
    NieuwBest. Range("A1")
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.PasteSpecial Paste:=xlPasteColumnWidths
    Selection.PasteSpecial Paste:=xlPasteFormats
    ActiveWindow.DisplayGridlines = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.47244094488189)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.551181102362205)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
    End With
    NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
    ActiveWindow.Close
        Range("A1").Select

End Sub
Klik om te vergroten...

Nu zit de fout hier
Code: 
 Application.Reference:="Print_Area".Copy
Met vr gr
Jack
 
Even een snelle poging van mij (Let op: ongetest)

Code: 
Sub Opslaan_Nu()
Application.ScreenUpdating = False

Dim NieuwBest As Workbook
Set NieuwBest = Workbooks.Add

Windows(NieuwBest.Name).DisplayGridlines = False

ThisWorkbook.ActiveSheet.Range("Print_area").Copy
With NieuwBest.Sheets(1).Range("A1")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteFormats
End With

With NieuwBest.Sheets(1).PageSetup
    .LeftMargin = Application.InchesToPoints(0.47244094488189)
    .RightMargin = Application.InchesToPoints(0.47244094488189)
    .TopMargin = Application.InchesToPoints(0.551181102362205)
    .BottomMargin = Application.InchesToPoints(0.551181102362205)
End With

NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
NieuwBest.Close

ThisWorkbook.ActiveSheet.Range("A1").Select

Application.ScreenUpdating = True
End Sub
 
Finch zei:
Even een snelle poging van mij (Let op: ongetest)

Code: 
Sub Opslaan_Nu()
Application.ScreenUpdating = False

Dim NieuwBest As Workbook
Set NieuwBest = Workbooks.Add

Windows(NieuwBest.Name).DisplayGridlines = False

ThisWorkbook.ActiveSheet.Range("Print_area").Copy
With NieuwBest.Sheets(1).Range("A1")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteFormats
End With

With NieuwBest.Sheets(1).PageSetup
    .LeftMargin = Application.InchesToPoints(0.47244094488189)
    .RightMargin = Application.InchesToPoints(0.47244094488189)
    .TopMargin = Application.InchesToPoints(0.551181102362205)
    .BottomMargin = Application.InchesToPoints(0.551181102362205)
End With

NieuwBest.SaveAs Filename:="C:\Documents and Settings\Mijn documenten\Inkoop Orders\Order " & Range("M13").Value & ".xls"
NieuwBest.Close

ThisWorkbook.ActiveSheet.Range("A1").Select

Application.ScreenUpdating = True
End Sub
Klik om te vergroten...

Beste Finch,

Ik heb de code getest en het werkt bij mij in ieder geval perfect.:thumb:
Bedankt.

Met vr gr
Jack
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan