Option Explicit

Private Sub cmbAktZBearbeiten_Click()
Dim BearbZ As String, sPath As String

 '============================================================
  'Pfad zum Suchen der Datei im folgenden Ordner:
sPath = "H:\My Documents\TEST_Speicherort\"
  '============================================================

BearbZ = InputBox("Bitte Zeichen der zu  bearbeitenden Datei eingeben.")

If BearbZ = "" Then
MsgBox "Bitte ein Zeichen eingeben!"

ElseIf Dir(sPath & BearbZ & ".xls") = "" Then
MsgBox "Datei mit diesem Zeichen nicht vorhanden."

Else
Workbooks.Open Filename:=sPath & BearbZ & ".xls"
End If

End Sub


Private Sub cmbAktZNeu_Click()
Dim Zeichen
Dim byWert As Byte
Dim rng As Range

byWert = MsgBox("Bei der Angabe eines neuen Zeichens werden alle Eintragungen gelöscht!" & vbCrLf & _
"Soll ein neues Zeichen erfasst werden?", vbYesNo + vbCritical)

If byWert = vbYes Then
Zeichen = InputBox("Bitte das Zeichen eingeben.")
    Sheets("Status").Activate
    Range("E1:H1") = Zeichen
    Call Kopieren
     
xLöschen Sheets(1).Range("D5:H9,D11:H19,D22:H29")
xLöschen Sheets(2).Range("D4:H10,D12:H17")
xLöschen Sheets(3).Range("D4:H8,D11:H15")

Else
Exit Sub
End If

   
End Sub

Private Function xLöschen(rng As Range)
Dim R&, C&, V

For Each V In rng
If Not IsError(V) Then
If LCase(V) = "x" Then
V.Value = ""
End If
End If
Next
End Function


Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
 
    With Target
 If InStr(1, .Address, ":") = 0 Then
        OnChange1 Target, .Row, .Column, .Value
        OnChange2 Target, .Row, .Column, .Value
        End If
    End With
     
Application.EnableEvents = True
End Sub
 
Private Function OnChange1(Target As Range, R&, C&, V)
Dim NichtLeer As Boolean, Wert#
On Error Resume Next
 
    Select Case R
    Case Is > 9, Is < 5
        Exit Function
    End Select
         
    Select Case C
    Case Is > 8, Is < 4
        Exit Function
    Case 4: If V = "x" Then Wert = 1
    Case Else: If V = "x" Then Wert = 2
    End Select
    If V <> "" Then
        Range(Cells(R, 4), Cells(R, 8)).ClearContents
        Target.Value = "x"
    End If
        
    If Wert <> 0 Then
        Cells(6 + R, 3) = Wert
    Else
        If Cells(R, 8).End(xlToLeft).Column < 4 Then
            Cells(6 + R, 3) = ""
        End If
    End If
     
End Function
 
Private Function OnChange2(Target As Range, R&, C&, V)
Dim rng As Range, sumCell As Range
On Error Resume Next
 
    Set sumCell = Cells(R, 11)
    If R < 5 And R < 33 Or V = "" Then
        sumCell = ""
        Exit Function
    End If
 
    Select Case C
    Case Is > 8, Is < 4: Exit Function
    End Select
 
    Set rng = Range(Cells(R, 4), Cells(R, 8))
    rng.ClearContents
    Target.Value = "x"
    sumCell = (8 - C) * Cells(R, 3) 'Summe
 
End Function

So, das wäre der Code komplett. Der Fehler taucht genau bei " If InStr(1, .Address, ":") = 0 Then" auf. Wegen der Datei... Kann sie schon hochladen, muss sie nur umändern wegen den Inhalten und du müsstest mir sagen, wie ich das hier genau machen kann?!

Vielen Dank, dass du dich meinem Problem annimmst, ist wirklich top!!