Hallo zusammen und Frohe Ostern,
suche einen VBA-Code für folgendes Problem. Im Tabellenblatt Anlagen_Total werden Eingaben in den Zellen A9:A30 getätigt und dadurch jeweils zur Eingabe ein neues, vorgefertigtes „Basis“-Tabellenblatt kopiert und mit dem eingegebenen Namen als Tabellennamen angelegt. In diesen Tabellenblätter werden Werte gebildet(Zelle H1, H2), die ich zur besseren Übersicht im Tabellenblatt Anlagen_Total zurück schreiben möchte. Gibt es hierfür eine Lösung ? Anbei habe ich den VBA Code angehangen in der diese Funktion integriert werden soll.
Option Explicit
Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
If Zelle.Value „“ Then
If Not Vorhanden(Zelle.Value) = True Then
Worksheets(„Basis“).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Zelle.Value
End If
End If
Next Zelle
hell:
If Err.Number 0 Then
MsgBox Err.Number & vbCrLf & Err.Description
Resume Next
End If
End Sub
Sub Loesche(ByRef Target As Range)
Dim wks As Worksheet, Zelle As Range, Vorh As Boolean
Application.DisplayAlerts = False
With Worksheets(„Anlagen Total“)
For Each wks In Worksheets
If IsNumeric(wks.Name) Then
If Application.WorksheetFunction.CountIf(.Range(„A9:A22“), Val(wks.Name)) = 0 Then
wks.Delete
End If
End If
Next wks
End With
Application.DisplayAlerts = True
End Sub
Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
If wks.Name = strWert Then
Vorhanden = True
Exit For
End If
Next wks
End Function
Vielen Dank für die Hilfe.
Gruss Rossi
Hallo Rossi,
suche einen VBA-Code für folgendes Problem. Im Tabellenblatt
Anlagen_Total werden Eingaben in den Zellen A9:A30 getätigt
entscheide dich bitte mal zwischen A30 und A22 
Ggfs. mußte das im neuen Code abändern.
In diesen Tabellenblätter werden
Werte gebildet(Zelle H1, H2), die ich zur besseren Übersicht
im Tabellenblatt Anlagen_Total zurück schreiben möchte.
Wohin in Anlagen_Total?, Ich hab jetzt mal C9:smiley:22 genommen.
Diese Mappe hat den nachstehenden Code:
http://www.uploadagent.de/show-183910-1333982350.html
Gruß
Reinhard
In das Modul von Anlagen_Total
Option Explicit
Sub Worksheet\_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("A9:A22"))
If Target Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Call Erstelle(Target)
Call Loesche
Call Formel
Worksheets("Anlagen Total").Activate
Application.ScreenUpdating = True
End Sub
In ein Standardmodul:
Option Explicit
Sub Worksheet\_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("A9:A22"))
If Target Is Nothing Then Exit Sub
Call Erstelle(Target)
End Sub
Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
If Zelle.Value "" Then
If Not Vorhanden(Zelle.Value) = True Then
Worksheets("Basis").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Zelle.Value
End If
End If
Next Zelle
Worksheets("Anlagen Total").Activate
hell:
If Err.Number 0 Then
MsgBox Err.Number & vbCrLf & Err.Description
Resume Next
End If
End Sub
Sub Loesche()
Dim wks As Worksheet
Application.DisplayAlerts = False
With Worksheets("Anlagen Total")
For Each wks In Worksheets
If IsNumeric(wks.Name) Then
If Application.WorksheetFunction.CountIf(.Range("A9:A22"), Val(wks.Name)) = 0 Then
wks.Delete
End If
End If
Next wks
End With
Application.DisplayAlerts = True
End Sub
Sub Formel()
Dim Zelle As Range
Application.EnableEvents = False
With Worksheets("Anlagen Total")
.Range("C9:smiley:22").ClearContents
For Each Zelle In .Range("A9:A22")
If Zelle.Value 0 Then
Zelle.Offset(0, 2).Formula = "='" & Zelle.Value & "'!H1"
Zelle.Offset(0, 3).Formula = "='" & Zelle.Value & "'!H2"
End If
Next Zelle
End With
Application.EnableEvents = True
End Sub
Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
If wks.Name = strWert Then
Vorhanden = True
Exit For
End If
Next wks
End Function
Danke für die Rückmeldung. Der Bereich A9:Axx variert gerade etwas, daher die verschiedenen Angaben. Funktioniert Super.
Bist mein persönlicher Held.
Vielen Dank