Makro erweitern - Ordner aus Blattname erstellen
17.03.2015 10:05:08
Ulf
ich möchte meine Vorlage noch verfeinern, weiß aber nicht wie.
Im Blatt "20µ-50µ" SpalteB wird eine Ser.Nr. vergeben. Es wird ein neues Blatt mit dieser Ser.Nr. erstellt. Soweit alles perfekt.
Jetzt möchte ich, wenn eine Ser.Nr. vergeben wird im Ordner: P:\Operations-Produktion_Daten\FKL Laser\Prüffeld\FL 0xx\FL MMS Adapter\ ein Ordner mit der Ser.Nr. erstellt wird.
Makros zum erstellen von Ordnern habe ich gefunden. Nur habe ich keinen Plan wie ich die in mein bestehndes Makro einbinde.
Kann mir bitte jemand helfen? - Danke
https://www.herber.de/bbs/user/96415.xlsm
Makro:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, _
s As String
If Target.Column = 2 And Target.Row > 1 And Target.Count = 1 And Target "" Then
'prüfen, ob es die Tabelle schon gibt!
On Error Resume Next
'Leerzeichen vorn & hinten entfernen
s = Trim(Target.Value)
Set ws = ThisWorkbook.Worksheets(s)
On Error GoTo 0
If Not (ws Is Nothing) Then
MsgBox "Die Tabelle '" & s & "' gibt es schon!", 16 + vbSystemModal, "F e h l e r..."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Set ws = Nothing
Exit Sub
End If
With ThisWorkbook
.Worksheets("Vorlage").Copy After:=.Sheets(.Sheets.Count)
End With
ActiveSheet.Name = s
Me.Activate
Me.Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:=Target & "!A1"
Set ws = Target.Parent
'='010'!$C$3
ws.Range("A" & Target.Row).Formula = "='" & s & "'!$D$3"
ws.Range("C" & Target.Row).Formula = "='" & s & "'!$D$6"
ws.Range("G" & Target.Row).Formula = "='" & s & "'!$D$4"
ws.Range("H" & Target.Row).Formula = "='" & s & "'!$D$5"
ws.Range("I" & Target.Row).Formula = "='" & s & "'!$B$12"
ws.Range("J" & Target.Row).Formula = "='" & s & "'!$D$13"
ws.Range("K" & Target.Row).Formula = "='" & s & "'!$G$20"
ws.Range("L" & Target.Row).Formula = "='" & s & "'!$G$25"
ws.Range("M" & Target.Row).Formula = "='" & s & "'!$N$10"
ws.Range("V" & Target.Row).Formula = "='" & s & "'!$D$2"
Set ws = Nothing
End If
End Sub