Code anpassen

Hallo Community,


Ich habe jetzt einen Code der funktioniert, aber wenn ich die Excel Datei schließe und wieder öffne gibt der Code einen Error.


Hier ist der Code:


Sub Test

ActiveCell.Select
Selection.Copy
Sheets"Prüfungstabelle".Select
Range"A1".Select
ActiveSheet.Paste
Range"A2".Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=FORMULATEXTR[-1]C"
Range"A2".Select
Selection.Copy
Range"B1".Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.ClearContents
Range"A2".Select
Selection.Copy
Range"B1".Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range"I1".Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range"A2".Select
Application.CutCopyMode = False
Selection.ClearContents
Range"B1".Select
Selection.TextToColumns Destination:=Range"B1", DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=True, OtherChar:= _
"!", FieldInfo:=ArrayArray1, 1, Array2, 1, Array3, 1, Array4, 1, Array5, 1, _
Array6, 1, Array7, 1, TrailingMinusNumbers:=True
Range"B1".Select
Selection.Delete Shift:=xlToLeft
Range"C1:G1".Select
Selection.Delete Shift:=xlToLeft
Range"C1".Select
Selection.TextToColumns Destination:=Range"C1", DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, OtherChar _
:="!", FieldInfo:=ArrayArray1, 1, Array2, 1, Array3, 1, Array4, 1, Array5, _
1, Array6, 1, TrailingMinusNumbers:=True
Range"C1".Select
Selection.Delete Shift:=xlToLeft
Range"D1:H1".Select
Selection.ClearContents


Dim wsh As Worksheet
Dim sWert As Double
Dim c As Range
Dim Firstaddress As String
Dim PTName As String

With Sheets"Prüfungstabelle"
Set wsh = Sheets.Range"B1".Value
sWert = .Range"A1"
PTName = .Range"C1"
End With

With wsh
Set c = .PivotTablesPTName.TableRange1.FindsWert
If Not c Is Nothing Then
Firstaddress = c.Address
Do
c.Interior.Color = vbRed
Set c = .PivotTablesPTName.TableRange1.FindNextc
Loop While c.Address <> Firstaddress
Else
MsgBox "Suchwert nicht gefunden"
End If
End With

Rows"1:1".Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows"1:1".Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets"KS".Select

End Sub


Ich hoffe ihr könnt mir helfen den Code zu sortieren und zu säubern, dass er immer funktioniert.


vielen Dank und liebe Grüße,

LiNy