AW: MSG Box wenn neue Eingabe erfolgt
25.01.2016 09:13:10
Hartmut
Hi Herbert,
sorry wenn das verwirrend herüber kommt. Das macht wohl das fehlende Fachwissen für diese Materie.
Hier ist der komplette Code von meinem kleinen Tool.
Ich denke das es alles vereinfacht. Ich habe gedacht es reicht wenn ich nur den Auszug eintrage von den störenden Elementen.
Nun gut hier ist der Code.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Pfad$, Ordner$, FS, Mfile1$, Mfile2$, Mfile3$, Mfile4$, SP%, ZE%, DN%, Letzter%
SP = 6 'Eintragungen in Spalte 6 werden zum generieren verwendet
ZE = 2 'Ab Zeile 2 werden eintragungen vorgenommen
If Not Intersect(Target, Columns(SP)) Is Nothing And Target.Row >= ZE Then
If Target.Offset(-1, 0) "" Then 'prüfen ob kein Eintrag vorhanden ist
Set FS = CreateObject("Scripting.FileSystemObject")
Pfad = "\\CMB\8.24_Material\_TKIS\"
Mfile1 = "\Testsheet1.xlsx"
Mfile2 = "\Testsheet2.xlsx"
DN = 4
Letzter = IIf(Target.Row = ZE, 0, Right(Cells(Target.Row - 1, DN).Value, 3)) ' _
Letzte Ordner
Ordner = Format(Letzter + 1, """MRR-E&I_""000")
Application.EnableEvents = False
Cells(Target.Row, DN).Value = Ordner
Application.EnableEvents = True
If Dir(Pfad & Ordner, vbDirectory) = "" Then
MkDir Pfad & Ordner
FS.copyfile Pfad & Mfile1, Pfad & Ordner & Mfile1, True
FS.copyfile Pfad & Mfile2, Pfad & Ordner & Mfile2, True
MsgBox "Ordner angelegt" & vbLf & vbLf & "und Sheets eingefügt"
Else
MsgBox "Ordner existiert bereits"
End If
Else
MsgBox "Leerzeile vorher darf nicht sein"
End If
End If
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
Application.EnableEvents = True
If Not Intersect(Target, Range("o2:o1000")) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1) = Now
End If
If Not Intersect(Target, Range("q2:q1000")) Is Nothing And Target.Count = 1 Then
Target.Offset(, 1) = Now
End If
'If Not Intersect(Target, Range("t5:t12000")) Is Nothing And Target.Count = 1 Then
'Target.Offset(, 1) = Now
'End If
'If Not Intersect(Target, Range("v5:v12000")) Is Nothing And Target.Count = 1 Then
'Target.Offset(, 1) = Now
'End If
End Sub
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("d2:d500")
If Not Intersect(Target, Bereich) Is Nothing Then
Application.Dialogs(xlDialogOpen).Show "\\CMB\8.24_Material\_TKIS\\" & Target & "\"
End If
End Sub
Das ist jetzt der komplette Code ohne deinen Zusatz/Änderung.
Vielen Dank schon jetzt für deine tolle Unterstützung.
Gruß
Hartmut