Sub
Aufbereitung()
Dim
cDir
As
String
, sPath
As
String
, i
As
Long
Dim
wbQuelle
As
Workbook, ws
As
Worksheet
Application.ScreenUpdating =
False
Application.EnableEvents =
False
Application.DisplayAlerts =
False
sPath = ThisWorkbook.Path & "\verarbeiten\"
cDir = Dir(sPath &
"*.xlsm"
)
Do
While
cDir <>
""
Set
wbQuelle = Workbooks.Open(sPath & cDir)
With
wbQuelle
.Worksheets(
"Übersicht"
).Delete
.Worksheets(
"BEZ"
).Delete
For
Each
ws
In
.Worksheets
With
ws
.Unprotect
"controlling2020"
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
If
.Range(
"M173"
) <> 0
Then
.Outline.ShowLevels RowLevels:=2
.Cells.Rows.Ungroup
For
i = 2
To
12
.Cells(8, i) =
"Spalte "
& Split(.Cells(8, i).Address,
"$"
)(1)
Next
i
.Range(
"$A:$M"
).AutoFilter Field:=13, Criteria1:=
"<>0"
, Operator:=xlFilterValues
.Range(
"$A:$M"
).AutoFilter Field:=2, Criteria1:=
"<>"
.Columns(
"D:L"
).Delete Shift:=xlToLeft
.Columns(
"B:B"
).Insert Shift:=xlToRight
.Range(
"B10"
) = .Range(
"D3"
)
.Range(
"B10"
).Copy
.Range(
"B10:B"
& .Range(
"B10"
).Offset(0, 1).
End
(xlDown).Row).PasteSpecial Paste:=xlPasteValues
End
If
End
With
Next
ws
End
With
cDir = Dir
Loop
Set
wbQuelle =
Nothing
Application.EnableEvents =
True
Application.DisplayAlerts =
True
End
Sub