Codefehler bei fortlaufender Nummerierung
17.08.2006 17:35:10
Raschid
Habe mich als Neuling in VBA bisher halbwegs durchgeschlagen, komme aber an einem Punkt nicht mehr weiter. Vielleicht hat jemand den entscheidenden Tip?
Ich habe in Excel 2003 einen Reklamationsreport auf Basis einer Vorlage (.xlt) erstellt. Dieser soll beim Öffnen automatisch eine fortlaufende Nummerierung erhalten und mit dieser Nummer auch automatisch gespeichert werden.
Hierzu bin ich in einem Forum auf einen gut passenden Code gestoßen, den ich angepasst habe. Leider funktioniert es noch nicht richtig:
- beim ersten Öffnen eines Dokumentes (.xls) aus der Vorlage wird tatsächlich der Zähler auf "1" gesetzt und das Dokument unter "Reklamationsreport1" an der gewünschten Stelle gespeichert.
- Öffne ich aus der Vorlage heraus aber ein weiteres Dokument, will Excel dieses wieder unter "Reklamationsreport1" speichern und zählt nicht weiter hoch.
Excel müsste vermutlich den hochgezählten Wert "Nr" in der Vorlage speichern, was es wohl nicht tut?
Hier der Code (die ersten Zeilen lesen nur den Programmnutzer aus):
Option Explicit
Private Sub Workbook_Open()
With Worksheets("Reklamationsreport")
.Range("F2").Value = _
Application.UserName
'Excel Benutzer = Application.UserName
'Windows Benutzer = Environ("UserName")
End With
Dim intIndex As Integer, intLine As Integer
Dim intStartLine As Integer, intEndLine As Integer
Const Pfad = "H:\Reklamationen\"
If ThisWorkbook.CustomDocumentProperties.Count = 0 Then
ThisWorkbook.CustomDocumentProperties.Add Name:="Nr", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=0
End If
ThisWorkbook.CustomDocumentProperties("Nr") = ThisWorkbook.CustomDocumentProperties("Nr") + 1
ThisWorkbook.SaveAs Filename:=Pfad & "Reklamation" & ThisWorkbook.CustomDocumentProperties("Nr")
ThisWorkbook.Worksheets("Reklamationsreport").Range("B2") = ThisWorkbook.CustomDocumentProperties("Nr")
With ThisWorkbook.VBProject
For intIndex = 1 To .VBComponents.Count
With .VBComponents(intIndex).CodeModule
For intLine = 1 To .CountOfLines
If .ProcOfLine(intLine, 0) = "Workbook_Open" Then
If intStartLine = 0 Then
intStartLine = intLine
Else
intEndLine = intLine
End If
End If
Next
If intStartLine <> 0 Then
.DeleteLines intStartLine, intEndLine - intStartLine + 1
Exit For
End If
End With
Next
End With
End Sub
---
Stecke hier fest; wäre also eine große Hilfe, wenn jemand Rat wüsste. Vielen Dank vorab.