Private Function EbenenFuellen() Dim headRow1, headRowN, headCol1, headColN, dataRow1, dataRowN, dataCol1, dataColN As Integer headCol1 = 1 If Cells(9, 1).Value Like "*Schicht*" Then headRow1 = 10 Else headRow1 = 8 End If dataRow1 = headRow1 Do dataRow1 = dataRow1 + 1 Loop Until Cells(dataRow1, headCol1).Value <> "" headRowN = dataRow1 - 1 dataCol1 = headCol1 Do dataCol1 = dataCol1 + 1 Loop Until IsNumeric(Cells(dataRow1, dataCol1).Value) headColN = dataCol1 - 1 dataRowN = dataRow1 Do While Cells(dataRowN + 1, dataCol1).Value <> "" dataRowN = dataRowN + 1 Loop dataColN = dataCol1 Do While Cells(dataRow1, dataColN + 1).Value <> "" dataColN = dataColN + 1 Loop Dim c, r As Integer Dim txt As String Rem Zeilen füllen For c = headCol1 To headColN txt = "" For r = dataRow1 To dataRowN If Cells(r, c).Value = "" Then If c > headCol1 And r > dataRow1 Then If Cells(r, c - 1).Value <> Cells(r - 1, c - 1).Value Then txt = Cells(r, c - 1).Value End If End If Cells(r, c).Value = txt Else txt = Cells(r, c).Value End If Next r Next c Rem Spalten füllen For r = headRow1 To headRowN txt = "" For c = dataCol1 To dataColN If Cells(r, c).Value = "" Then If c > dataCol1 And r > headRow1 Then If Cells(r - 1, c).Value <> Cells(r - 1, c - 1).Value Then txt = Cells(r - 1, c).Value End If End If Cells(r, c).Value = txt Else txt = Cells(r, c).Value End If Next c Next r End Function Sub Workflow(datei As String) Dim Current As Worksheet Workbooks.Open Filename:=datei For Each Current In Worksheets Current.Select EbenenFuellen Next ActiveWorkbook.Save Application.Quit End Sub Sub Makro1() Workflow ActiveWorkbook.Path + "\FIBU_Gebrauchtwagen.xls" End Sub