Code überprüfen
20.07.2003 10:26:57
Franz W.
mit Eurer tatkräftigen Unterstützung habe ich den folgenden Code zusammengestellt, der auch funktionert. Vielleicht mag mal einer drüber schauen, ob noch Fehler drin sind, die ich noch nicht bermerkt habe, oder ob es sonst noch was dazu zu sagen gibt.
2 Schwächen (mindestens 2, die, die mir klar sind... ;-)) ! ) sind noch drin:
- Wie es heißt sollte u.a. "GoTo" vermieden werden: ist es möglich das
" GoTo KdPruef "
zu umgehen?
- " Workbooks("OffeneRechnungen.xls").Worksheets("Offene").Activate " - dritte Zeile nach " KdPruef: " bring ich auch nicht weg. Ohne geht's nur wenn die Datei "OffeneRechnungen.xls" erst geöffnet werden muss. Dadurch wird sie wohl aktiviert. Wenn sie schon offen ist und ich die explizite Aktivierung rauslasse findet er schon vorhandene Werte nicht und schreibt einen neuen Eintrag.
Das Makro wird durch Button ausgelöst.
Sub DatenInOffRechnUebertr()
Dim Wb As Workbook, sWb As String
Dim Found As Range, sSearch As String
Dim LoLetzte& '(As Long)
Dim KdNr%, KdTitel$, KdNName$, KdVName$, Kdco$
KdNr = ActiveCell
KdTitel = ActiveCell.Offset(0, 1).Value
KdNName = ActiveCell.Offset(0, 2).Value
KdVName = ActiveCell.Offset(0, 3).Value
Kdco = ActiveCell.Offset(0, 4).Value
Application.ScreenUpdating = False
''' Prüfen ob "OffeneRechnungen.xls" schon offen
sWb = "OffeneRechnungen.xls"
For Each Wb In Application.Workbooks
If Wb.Name = sWb Then
GoTo KdPruef
End If
Next
Workbooks.Open Filename:="E:\Microsoft\Excel\Bernhard\OffeneRechnungen.xls"
KdPruef:
''' Prüfen ob Kundennummer schon vorhanden
sSearch = Format(KdNr, "000")
Workbooks("OffeneRechnungen.xls").Worksheets("Offene").Activate
Workbooks("OffeneRechnungen.xls").Worksheets("Offene").Unprotect
With Workbooks("OffeneRechnungen.xls").Worksheets("Offene")
LoLetzte = 65536
If Range("A65536") = "" Then LoLetzte = Range("A65536").End(xlUp).Row
Set Found = Range("A1:A" & LoLetzte).Find(sSearch, LookIn:=xlValues)
If Not Found Is Nothing Then ' KdNr schon vorhanden: Werte überschreiben
With Workbooks("OffeneRechnungen.xls").Worksheets("Offene").Range(Found.Address)
.Offset(0, 1) = KdTitel
.Offset(0, 2) = KdNName
.Offset(0, 3) = KdVName
.Offset(0, 4) = Kdco
End With
Else ' KdNr noch nicht vorhanden: neue Zeile anlegen
With Workbooks("OffeneRechnungen.xls").Worksheets("Offene")
LoLetzte = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LoLetzte, 1) = KdNr
.Cells(LoLetzte, 2) = KdTitel
.Cells(LoLetzte, 3) = KdNName
.Cells(LoLetzte, 4) = KdVName
.Cells(LoLetzte, 5) = Kdco
End With
End If
End With
Workbooks("OffeneRechnungen.xls").Worksheets("Offene").Protect
Workbooks("OffeneRechnungen.xls").Save
'Workbooks("OffeneRechnungen.xls").Close SaveChanges:=True
End Sub
Schon mal vielen Dank für Eure Mühe.
Grüße
Franz