AW: VBA /Tabellenblatt anlegen und kopieren
04.09.2020 22:35:10
fcs
Hallo Klaus,
hier ein Makro zur Teilung der Liste.
für eine einfachere weitere Bearbeitung werden noch Leerstring in Zellen und führende/nachgestellte Leerzeichen in den Texten entfernt und Zahltexte in Zahlen umgewandelt.
LG
Franz
Sub Zeitliste_Teilen()
Dim wkb As Workbook, wksListe As Worksheet, wksVorlage As Worksheet
Dim Zeile As Long, Zeile_1 As Long, Zeile_2 As Long
Dim wksName As Worksheet, varName
Dim rngZelle As Range
Dim varSuchen, s1stAddress As String
Dim Spa_L As Long, Zei_L As Long
Application.ScreenUpdating = False
Set wkb = ActiveWorkbook
Set wksListe = ActiveSheet
Range("A1").Select
Application.StatusBar = "Liste wird vorbereitet"
With wksListe
'letzte Zeile und Spalte ermitteln
With .UsedRange
Zei_L = .Row + .Rows.Count - 1
Spa_L = .Column + .Columns.Count - 1
End With
'Leerstrings und führende/nachfolgende Leerzeichen löschen
For Each rngZelle In .Range(.Cells(1, 1), .Cells(Zei_L, Spa_L)).Cells
rngZelle.Value = Trim(rngZelle.Text)
If rngZelle.Text = "" Then rngZelle.ClearContents
Next
'Zahlenformat setzen in palten mit Zahlenwerten
.Range(.Columns(5), Columns(15)).NumberFormat = "0.00;-0.00;0.00"
'Zahlentext in Zahlen umwandeln
For Each rngZelle In .Range(.Cells(1, 5), .Cells(Zei_L, 15)).Cells
If IsNumeric(rngZelle.Text) Then rngZelle = CDbl(rngZelle.Text)
Next
'Spaltenbreiten formatieren
.Columns(1).ColumnWidth = 5
.Columns(2).ColumnWidth = 28
.Columns(3).ColumnWidth = 16
.Range(.Columns(4), .Columns(8)).ColumnWidth = 7.5
.Range(.Columns(9), .Columns(15)).ColumnWidth = 8
End With
'Vorlage anlegen
Application.StatusBar = "Vorlage wird angelegt"
wksListe.Copy before:=wksListe
Set wksVorlage = ActiveSheet
With wksVorlage
.UsedRange.EntireRow.Delete
.Name = "Vorlage"
End With
Zeile_1 = 1
With wksListe
varSuchen = "Zeitnachweisliste"
Set rngZelle = .Range("B:B").Find(After:=.Cells(.Rows.Count, 2), What:=varSuchen, _
LookIn:=xlValues, lookat:=xlWhole)
If rngZelle Is Nothing Then
MsgBox "Suchbegriff """ & varSuchen & """ nicht gefunden"
GoTo Beenden
End If
s1stAddress = rngZelle.Address
Zeile_1 = rngZelle.Row
Do
Set rngZelle = .Range("B:B").FindNext(After:=rngZelle)
If rngZelle.Address = s1stAddress Then
Zeile_2 = Zei_L
Else
Zeile_2 = rngZelle.Row - 1
End If
varName = .Cells(Zeile_1 + 3, 2).Text
varName = Left(Mid(varName, Len("Mitarbeiter : ")), 31)
Application.StatusBar = "Blatt für MA " & varName & " wird angelegt"
wksVorlage.Copy After:=wkb.Sheets(wkb.Sheets.Count)
.Range(.Rows(Zeile_1), .Rows(Zeile_2)).Copy wkb.Sheets(wkb.Sheets.Count).Range("A1")
wkb.Sheets(wkb.Sheets.Count).Name = varName
If Zeile_2 = Zei_L Then Exit Do
Zeile_1 = rngZelle.Row
Loop
End With
Beenden:
Application.DisplayAlerts = False
wksVorlage.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.StatusBar = False
MsgBox "Fertig", vbOKOnly, "Liste teilen"
End Sub