AW: Automatisch Ordner erstellen
04.09.2020 12:16:22
Ylmz-006
Hallo Nepumuk,
Diese Code habe ich in der Tabellenreiter stehen.
Gruß
Option Explicit
Private Const FOLDER_PATH As String = "C:\Users\Technik\Pictures\Akten\"
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strFoldername As String, strAlternativeFoldername As String
If Target.Column = 2 Then
strAlternativeFoldername = Replace(Replace(Target.Text, "/", "-"), "-", "_")
strFoldername = Dir$(FOLDER_PATH & "*" & _
Replace(Target.Text, "/", "-") & "*", vbDirectory)
If strFoldername = vbNullString Then strFoldername = _
Dir$(FOLDER_PATH & "*" & strAlternativeFoldername & "*", vbDirectory)
If strFoldername vbNullString Then
Call Shell("explorer.exe /e, " & FOLDER_PATH & strFoldername, vbNormalFocus)
Else
Call MsgBox("Ordner nicht gefunden.", vbExclamation, "Hinweis")
End If
Cancel = True
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
ProjektArchivieren Target
On Error Resume Next
If Not Intersect(Target, Range("B:Y")) Is Nothing Then
Range("M12").Sort Key1:=Range("M12"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub