AW: Neues Tab über VBA erstellen
10.10.2017 10:28:49
UweD
Hallo
hier mal ein Code
Sub Blätter()
On Error GoTo Fehler
Dim TB As Worksheet, SP As Integer, i As Integer
Dim LR As Integer, EZ As Integer, NName As String
'*** bescheunigt das Makro
Application.ScreenUpdating = False
'*** Stammdaten Anfang
Set TB = Sheets("Übersicht") 'aus bestimmtem Blatt
SP = 2 'Spalte B
EZ = 5 'Kopfzeile
'*** Stammdaten Ende
LR = TB.Cells(TB.Rows.Count, SP).End(xlUp).Row
For i = EZ + 1 To LR
NName = TB.Cells(i, SP) 'Monatsname
If Not TBVorhanden(NName) Then
'wenn nicht vorhanden dann anlegen..
Sheets.Add(after:=Sheets(Sheets.Count)).Name = NName
With Sheets(NName)
' Zeilen kopieren
TB.Rows(EZ).Copy .Rows(EZ) 'Kopfzeile
TB.Rows(i).Copy .Rows(EZ + 1)
'Datenüberprüfung setzen
With .Cells(EZ, SP)
With .Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & TB.Name & "!" & _
Cells(EZ + 1, SP).Resize(LR - EZ).Address
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End With
End With
End If
Next
'*** Fehlerbehandlung
Err.Clear
On Error GoTo Fehler
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Function TBVorhanden(ByVal vName As String) As Boolean
Dim sheetSuche As Worksheet
TBVorhanden = False
For Each sheetSuche In Worksheets
If UCase(sheetSuche.Name) = UCase(vName) Then
TBVorhanden = True
Exit Function
End If
Next sheetSuche
End Function
Was evtl. noch angepasst werden muss:
Im Übersichtsblatt steht die Kopfzeile in Reihe 5 und die Daten stehn darunter
Im Monatsblatt dann ab Zeile 6
ich hab jetzt alles auf Zeile 5 gelassen
LG UweD