Hallo liebe Exelgemeinde
Ich habe ein Problem, in einen bestehenden VBA-Code eine weitere Prüfung für die Spalten A und B einzufügen.
Der nachfolgende Code1 funktioniert in seiner Aufgabe einwandfrei. Der zweite Code, die gewünschte Überprüfung der beiden Spalten, wird allerdings nicht mit ausgeführt. Als alleiniger Code funktioniert auch dieser.
Ich benutze noch Exel 2003
Private Sub worksheet_Change(ByVal Target As Range)
' Zeilen
überprüfen und kopieren sowie Verschieben der entsprechenden pdf-Datei
Dim rngBer As Range
Dim rngObj As Range
Dim Sh As Worksheet
Dim objFSO As Object
Dim datei As String
On Error GoTo Err_Handler
' Datei verschieben "aktuell" --> "zur Zeit in Abrechnung"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Application.EnableEvents = False 'in diesem Code nicht nötig (zu Testzwecken eingeschaltet)
If Not Application.Intersect(Target, Range("M8:M1000")) Is Nothing Then
If IsDate(Target) = True Then
datei = "X:\Programme\Abrechnung\aktuell\" & Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) & ".pdf"
If objFSO.FileExists(datei) = True Then
objFSO.MoveFile datei, "X:\Programme\Abrechnung\zur Zeit in Abrechnung\"
MsgBox ("Datei " & Cells(Target.Row, 2) & ".pdf" & " wurde verschoben") ' kann bei Bedarf eingeschaltet werden
Else
MsgBox ("ACHTUNG: Datei ist im Ordner AKTUELL nicht vorhanden")
End If
End If
End If
Application.EnableEvents = True
' zu prüfende Zellen als Gesamtbereich festlegen
With Me
Set rngBer = Union(.Range("F8:F1000"), .Range("G8:G1000"), .Range("I8:I1000"), .Range("J8:J1000"), .Range("N8:N1000"), .Range("M8:M1000"))
End With
' gucken ob change im Zielbereich liegt
If Not Intersect(Target, rngBer) Is Nothing Then
With Target
' wenn ja, Abfrage ob alle Zellen gefüllt sind, wenn eine leer dann raus aus sub
For Each rngObj In rngBer
' nur wenn Zeile stimmt Inhalt prüfen
If rngObj.Row = .Row Then
' wenn Zeile stimmt, aber einer der 5 Checkbereiche leer, dann exit
If rngObj.Value = "" Then
GoTo Exit_This
End If
End If
Next rngObj
' sheetauswahl nach Angabe im Tabellenblatt, Spalte l
' nicht existent wird im err_handler abgearbeitet
Set Sh = Sheets(Right(Cells(.Row, 12), 4))
Application.EnableEvents = False
Application.ScreenUpdating = False
Sh.Unprotect
Me.Unprotect
' Zeile kopieren ins neue Sheet
Rows(.Row).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
' Zeile im Ursprungssheet löschen
Rows(.Row).Delete
Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Cells(ActiveCell.Row, 1).Select ' Rücksprung nach Spalte 1 (wurde am 15.7.14 geändert, da Rücksprung immer stattfand)
End If
Exit_This:
Application.EnableEvents = True
Application.ScreenUpdating = True
Set rngBer = Nothing
Set rngObj = Nothing
Set Sh = Nothing
Exit Sub
' Fehlerprüfroutine
Err_Handler:
Select Case Err.Number
Case 9
MsgBox "Das angegebene Tabellenblatt existiert nicht!"
Case Else
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End Select
Resume Exit_This
' End Sub
' BIS HIER FUNKTIONIERT DER CODE1 oben.
' Der nachfolgende Code müßte jedoch in Code1 mit eingebunden werden
' damit eine Überprüfung der Spalten A und B stattfindet.
' Vielen Dank schon mal für eure Bemühungen
Private Sub worksheet_Change(ByVal Target As Range)
Dim strPfad As String
Dim strDateiname As String
Dim Antwort
strPfad = "X:\Programme\Abrechnung\aktuell\"
'Prüfen, ob Eingabe in Spalten A oder B erfolgt ist, falls nicht, dann Makro beenden
If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
'Prüfen, ob in Eingaben sowohl in Zelle A als auch in Zelle B erfolgt sind
If IsEmpty(Cells(Target.Row, 1)) = False And IsEmpty(Cells(Target.Row, 2)) = False Then
'Falls beide Spalten ausgefüllt sind, dann Variable für Überprüfung erstellen - Leerzeichen ggf. löschen
strDateiname = Cells(Target.Row, 1).Value & " " & Cells(Target.Row, 2) & ".pdf"
strDatei = strPfad & strDateiname
'prüfen ob Datei bereits vorhanden ist, falls nicht dann Nachfrage
If Dir(strDatei) = "" Then
Antwort = MsgBox("Eine Datei mit dem Namen " & strDateiname & " existiert nicht! Soll die Datei per Scanner erzeugt werden?", 68, "Datei existiert nicht")
'Falls die Antwort Ja ausgewählt wird, dann Scan-Programm starten
If Antwort = vbYes Then Shell ("D:\Program Files (x86)\ScannerInterface 7\Scanner-Interface.exe"), vbNormalFocus
End If
End If
End Sub
' Aufruf eines Kalenders
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Me.Unprotect
Range("A8:O885").Interior.ColorIndex = xlNone
ActiveCell.Interior.ColorIndex = 6
Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Dim RaBereich As Range
If Target.Count > 1 Then Exit Sub
' Bereich der Wirksamkeit
Set RaBereich = Range("A8:A1000, D6, J8:J1000, M8:M1000, N8:N1000")
If Not Intersect(Target, RaBereich) Is Nothing Then
FRM_Kalender.Show
ElseIf Target.Row >= 4 And Target.Row <= 7 And Target.Column <= 12 Then
Kalender.Show
End If
' ActiveSheet.protect ("xxxxxx")
Set RaBereich = Nothing
End Sub
Mit freunlichen Grüßen
Horst
