AW: Wochentag aus Uberschrift in Zelle uebernehmen
25.06.2018 14:49:25
UweD
Hallo
so?
Modul1
Option Explicit
Sub Wochentage()
Dim TB1, TB2, Sp As Integer, LC As Integer, LR As Double, i As Double
Set TB1 = Sheets("Ausgang")
Set TB2 = Sheets("Ziel")
Sp = 6 'Spalte F
With TB2
'Reset
.Columns.Delete
'Daten kopieren
TB1.UsedRange.Copy .Cells(1, 1)
LR = .Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
'Temporäre Formel setzen
.Cells(1, Sp + 1) = "Tmp"
.Cells(2, Sp + 1).Resize(LR, 1).FormulaR1C1 = "=COUNTA(RC[-6]:RC[-1])"
'Filter setzen
Columns(Sp + 1).AutoFilter Field:=1, Criteria1:="0"
'leere Zeilen löschen
.Rows(2).Resize(LR).Delete xlUp
.AutoFilterMode = False
'Temp. Spalte löschen
.Columns(Sp + 1).Delete xlLeft
'Formel für Wochentag setzen und in Werte umwandeln
'wenn Doppelpunkt vorhanden...
LR = .UsedRange.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
With .Cells(2, Sp).Resize(LR - 1, 1)
.FormulaR1C1 = _
"=IF(ISNUMBER(FIND("":"",R[-1]C[-5])),R[-1]C[-5],R[-1]C)"
.Value = .Value
End With
'Filter setzen für Zellen mit Doppelpunkt
Columns(1).AutoFilter Field:=1, Criteria1:="*:*"
'leere Zeilen löschen
.Rows(2).Resize(LR).Delete xlUp
.AutoFilterMode = False
End With
End Sub
LG UweD