VBA Opslaan

[erwin87]

Beste ik zit met het volgende probleem ik ben nog niet zo goed in excel en zeker niet mer macro's, was ik bezig met een factuur bestandje te maken en had een bestandje gevonden met een print en opslaan macro in deze wat proberen aan te passen aleen de opslaan knop krijg ik niet helemaal naar mijn goesting het volgende gebeurd er als je op opslaan klikt het maakt een mapje aan met de klant naam daarin slaat hij dan het bestandje op onder factuurnummer zover heb ik het gekregen maar dan komt het dan sluit hij het geopende bestand af en opend hij het opgeslagen bestand en dat is net wat ik niet wil want als ik op de print knop druk dan print hij mooi de factuur af engaat hij naar een volgende factuurnummer en maakt hij de rest van de factuur blanco dus dan is het opgeslagen bestand terug blanco terwijl het originele gewoon terug blanco zou moeten zijn na het printen wie zou mij kunnen helpen zie de macro hieronder

alvast bedankt


Private Sub Opslaan1_Click()
Dim Pad As String
Dim Bestandsnaam As String

Bestandsnaam = Range("C8").Value & ".xls"
Pad = "C:\Users\Erwin\Documents\Excel\Facturen" & ActiveSheet.Range("C6").Value
MapBestaat Pad, True

'Application.DefaultFilePath = Pad
ActiveWorkbook.SaveAs Filename:=Pad & "\" & Bestandsnaam, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Range("A1").Select
'ActiveWorkbook.Close
End Sub

Private Function MapBestaat(strInputFolder As String, blnCreate As Boolean) As Boolean

On Error GoTo errorHandler
Dim strFolder As String, varrFolders As Variant, i As Long
MapBestaat = False
' input valideren
If InStr(1, strInputFolder, ":", vbBinaryCompare) <> 2 Then Exit Function
If InStr(1, strInputFolder, "\", vbBinaryCompare) = 0 Then Exit Function
If blnCreate Then ' probeer ontbrekende mappen aan te maken
' splits het pad in afzonderlijke mappen
varrFolders = Split(strInputFolder, "\", -1, vbBinaryCompare)
strFolder = varrFolders(LBound(varrFolders)) ' drive-letter
For i = LBound(varrFolders) + 1 To UBound(varrFolders)
strFolder = strFolder & "\" & varrFolders(i) ' voegt een map toe aan het pad
If Not Len(Dir(strFolder, vbDirectory)) > 0 Then
On Error Resume Next
MkDir strFolder ' maak een nieuwe map aan
On Error GoTo 0
End If
Next i
Erase varrFolders
' controleer en stel vast of de map bestaat
MapBestaat = Len(Dir(strFolder, vbDirectory)) > 0
Else ' stel vast dat de map al bestaat
MapBestaat = Len(Dir(strInputFolder, vbDirectory)) > 0
End If

Exit Function
errorHandler:
MsgBox "Error no. " & Err & " - " & Error, vbCritical, "Fout bij aanmaken map"

End Function

 

[Cobbe]

Ik zou even kijken in den Aldi voor een doos leestekens.

En zet uw code tussen tags aub.

 

[Roncancio]

Ik zie geen code om te printen.

Met vriendelijke groet,


Roncancio

 

[erwin87]

de volledige Code.

Private Sub PrintButton1_Click()
ActiveSheet.Unprotect
ActiveSheet.PageSetup.PrintArea = "$2:$75"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Range("C8") = Range("C8") + 1
Range("B19:J53").ClearContents
Range("B19").Select
ActiveSheet.Protect
End Sub

Private Sub Opslaan1_Click()
Dim Pad As String
Dim Bestandsnaam As String

Bestandsnaam = Range("C8").Value & ".xls"
Pad = "C:\Users\Erwin\Documents\Excel\Facturen" & ActiveSheet.Range("C6").Value
MapBestaat Pad, True


ActiveWorkbook.SaveAs Filename:=Pad & "\" & Bestandsnaam
End Sub

Private Function MapBestaat(strInputFolder As String, blnCreate As Boolean) As Boolean

On Error GoTo errorHandler
Dim strFolder As String, varrFolders As Variant, i As Long
MapBestaat = False
' input valideren
If InStr(1, strInputFolder, ":", vbBinaryCompare) <> 2 Then Exit Function
If InStr(1, strInputFolder, "\", vbBinaryCompare) = 0 Then Exit Function
If blnCreate Then ' probeer ontbrekende mappen aan te maken
' splits het pad in afzonderlijke mappen
varrFolders = Split(strInputFolder, "\", -1, vbBinaryCompare)
strFolder = varrFolders(LBound(varrFolders)) ' drive-letter
For i = LBound(varrFolders) + 1 To UBound(varrFolders)
strFolder = strFolder & "\" & varrFolders(i) ' voegt een map toe aan het pad
If Not Len(Dir(strFolder, vbDirectory)) > 0 Then
On Error Resume Next
MkDir strFolder ' maak een nieuwe map aan
On Error GoTo 0
End If
Next i
Erase varrFolders
' controleer en stel vast of de map bestaat
MapBestaat = Len(Dir(strFolder, vbDirectory)) > 0
Else ' stel vast dat de map al bestaat
MapBestaat = Len(Dir(strInputFolder, vbDirectory)) > 0
End If

Exit Function
errorHandler:
MsgBox "Error no. " & Err & " - " & Error, vbCritical, "Fout bij aanmaken map"

End Function





Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub