Macro in excel

[kdapp]

Ik heb de volgende macro:

Sub Offerte_save()
Dim offnum$, offdatum, pad$, filenaam$
Application.ScreenUpdating = False

ActiveSheet.Copy
ActiveSheet.Unprotect

Cells.Select
Selection.Copy
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues
On Error GoTo 0
[A1].Select

wiskol = "A:A,O:O"
Range(wiskol).Delete Shift:=xlToLeft

On Error Resume Next
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0

pad = "C:\Facturen\"
filenaam = pad & "Offerte " & [=offnum] & "_" & [=offdatum] & ".xls"

On Error GoTo myError
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=filenaam
ActiveWindow.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True
On Error GoTo 0
MsgBox (" De offerte is opgeslagen in het Archief ")
Exit Sub

myError:
If Sheets.Count = 1 Then ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox (" Er is een fout opgetreden. De offerte is niét opgeslagen. ")
Application.DisplayAlerts = True
On Error GoTo 0
End Sub

Het is de bedoeling dat deze macro werkt met een pad uit een worksheet dat RekeningenOverzicht heet het pad staat op H6 en ik heb H6 hernoemt naar LocatieBestanden.
ik wil geen vast pad hebben en wil het daarom ingeven in de worksheet op H6
Het staat nu vast op pad = "C:\Facturen\"
Heb al veel geprobeerd en ben bijna klaar met het programmaatje.

Wie kan mij helpen.

 

[Roncancio]

Om te verwijzen naar een cel uit het andere werkblad verander je...

pad = "C:\Facturen\"

..in ...

Worksheets("RekeningenOverzicht").Range("Locatiebestanden").Value

Met vriendelijke groet,


Roncancio

 

[kdapp]

Heb ik gedaan maar nu krijg ik een fout melding:

Fout -2147352565 (800 2000b) tijdes uitvoering
De index van de opgegeven verzameling valt buiten het berijk

 

[Roncancio]

Heb ik gedaan maar nu krijg ik een fout melding:

Fout -2147352565 (800 2000b) tijdes uitvoering
De index van de opgegeven verzameling valt buiten het berijk

Wat staat er precies in die cel?

Met vriendelijke groet,


Roncancio

 

[kdapp]

Het pad waar het bestand (actieve sheet) wordt weggeschreven

Klaas

 

[kdapp]

Het programmaatje zoals ik het nu heb gemaakt werkt prima maar het probleem is dat er nu mensen zijn die het graag willen hebben en ik niet van plan ben om bij iedereen langs te gaan om de macro aan te passen zodoende heb ik deze vraag gepost. Het is een offerte en Factuur programmaatje die ook de rekeningen bijhoud en alles vanaf één sheet bediend kan worden ik heb het niet helemaal zelf geschreven maar wel zo gemaakt dat alles met elkaar samenwerkt factuur nummers en offerte nummers worden automatisch gegenereerd in elk willekeurig format.
het enige dat er nog niet in zit is het bijhouden van de BTW voor de belasting dat moet ik nu nog handmatig doen maar ik denk dat ik dat morgen klaar heb.

 

[Warme bakkertje]

If Right([=Locatiebestanden], 1) = "\" Then
    pad = [=Locatiebestanden]
Else
    pad = [=Locatiebestanden] & "\"
End If

 

[kdapp]

Werkt helaas ook niet

Klaas

 

[Warme bakkertje]

Dit werkt 200% zeker(als al de cellen juist benoemd zijn natuurlijk)

Sub tst()
If Right([=Locatiebestanden], 1) = "\" Then
    pad = [=Locatiebestanden]
Else
    pad = [=Locatiebestanden] & "\"
End If
filenaam = pad & "Offerte " & [=offnum] & "_" & [=offdatum] & ".xls"
MsgBox filenaam
End Sub

 

[kdapp]

Sub Offerte_save()
Dim offnum$, offdatum, pad$, filenaam$
Application.ScreenUpdating = False

' kopieer werkblad naar nieuwe sheet
ActiveSheet.Copy
ActiveSheet.Unprotect

' vervang formules door waarden
Cells.Select
Selection.Copy
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues
On Error GoTo 0
[A1].Select

' wis overbodige rijen en kolommen (hier laten staan ivm index-formules
wiskol = "A:A,O:O"
Range(wiskol).Delete Shift:=xlToLeft

' wis alle shapes
On Error Resume Next
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0

' bepaal filenaam
pad = "C:\Facturen\"
filenaam = pad & "Offerte " & [=offnum] & "_" & [=offdatum] & ".xls"

' opslaan
On Error GoTo myError
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=filenaam
ActiveWindow.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True
On Error GoTo 0
MsgBox (" De offerte is opgeslagen in het Archief ")
Exit Sub

myError:
If Sheets.Count = 1 Then ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox (" Er is een fout opgetreden. De offerte is niét opgeslagen. ")
Application.DisplayAlerts = True
On Error GoTo 0
End Sub

Kan dit in de bestaande macro, deze heb ik nodig.
Als ik een nieuwe sub maak krijg ik de melding dat er een End sub verwacht wordt.
Ik zoek een oplossing in de bestaande macro dat maakt het nu zo lastig.
Ik weet dat er verschillende oplossingen zijn en ik heb er zelf ook veel maar kan niet de juiste combo vinden in bovenstaande macro

 

[Warme bakkertje]

Sub Offerte_save()
Dim offnum$, offdatum, pad$, filenaam$
Application.ScreenUpdating = False
' bepaal filenaam
If Right([=Locatiebestanden], 1) = "\" Then
    pad = [=Locatiebestanden]
Else
    pad = [=Locatiebestanden] & "\"
End If
filenaam = pad & "Offerte " & [=offnum] & "_" & [=offdatum] & ".xls"

' kopieer werkblad naar nieuwe sheet
ActiveSheet.Copy
ActiveSheet.Unprotect

' vervang formules door waarden
Cells.Select
Selection.Copy
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues
On Error GoTo 0
[A1].Select

' wis overbodige rijen en kolommen (hier laten staan ivm index-formules
wiskol = "A:A,O:O"
Range(wiskol).Delete Shift:=xlToLeft

' wis alle shapes
On Error Resume Next
ActiveSheet.DrawingObjects.Visible = True
ActiveSheet.DrawingObjects.Delete
On Error GoTo 0

' opslaan
On Error GoTo myError
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=filenaam
ActiveWindow.Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True
On Error GoTo 0
MsgBox (" De offerte is opgeslagen in het Archief ")
Exit Sub

myError:
If Sheets.Count = 1 Then ActiveWorkbook.Close
Application.ScreenUpdating = True
MsgBox (" Er is een fout opgetreden. De offerte is niét opgeslagen. ")
Application.DisplayAlerts = True
On Error GoTo 0
End Sub

 

[kdapp]

Hartelijk bedankt,
:thumb::thumb::thumb:
het programmaatje werkt nu zoals ik het graag zou willen hebben.
nog een paar kleine dingen en dan is het klaar.

Klaas