Sub Angebot_Kopieren()
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim Spalte As Integer
Dim ZielSpalte As Integer
Set wksQuelle = ThisWorkbook.Worksheets("Ausarbeitung")
Set wksZiel = Workbooks.Add.Worksheets(1)
wksZiel.Name = "Angebot"
ZielSpalte = 1
For Spalte = 1 To Tabelle1.UsedRange.Columns.Count
If wksQuelle.Cells(1, Spalte).Value = "Ja" Then
wksQuelle.Columns(Spalte).Copy wksZiel.Columns(ZielSpalte)
ZielSpalte = ZielSpalte + 1
End If
Next Spalte
Dim Zelle As Range
For Each Zelle In wksZiel.UsedRange
If Zelle.HasFormula = True Then
Zelle.Value = Zelle.Value
Zelle.Font.ColorIndex = 0
End If
Next Zelle
ActiveSheet.Rows("1:4").Delete
Cells.ClearOutline
Range(Cells(1, 1).End(xlToRight), Cells(1, Columns.Count).End(xlToLeft)).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A2").Select
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub