Hallo,   

das folgende Programm führt mir den letzten Befehl:

If Target.Column = 4.........

nicht mehr aus.

Ich denke der Fehler liegt am Mittelteil des Programms, worin die Schleife nicht beendet wird. Weiß aber nicht genau wo der Fehler liegt.

Bitte um schnelle Hilfe......Danke im voraus

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Const strDATEI3PFAD As String = "*********** TK1,TK5_ab2006.XLS"
Const strDATEI3NAME As String = "Rueckenschild TK1,TK5_ab2006.xls"
Dim x3WB As Excel.Workbook
Dim Quelle As Workbook
Dim boVorhanden As Boolean
Dim FreieZeile As Long
Dim ANSW As Long
Dim anzDurchlauf As Long
Dim answDurchlauf As Integer
Dim lngCol As Long
Dim OrdnerNr As Range

Set Quelle = ThisWorkbook

    Cancel = True
    If Target.EntireRow.Columns("T") <> "N" Then Exit Sub
    If Target.Column = 5 Then
     
        VERZEIC = "**************"

        MERKER = VERZEIC & Cells(Target.Row, 19) & "*"
        UNTERVERZEIC = Dir(MERKER, vbDirectory)
   
        Pfad = VERZEIC & UNTERVERZEIC
        PFAD1 = Pfad
                    
       
        TEST = Dir(Pfad, vbDirectory)
       
        If Len(TEST) < 2 Then
            MsgBox ("Pfad nicht vorhanden!")
            GoTo weiter1
        End If
       
        Shell "explorer " & Pfad, vbMaximizedFocus
    End If
   
   
'******
If Target.Column = 2 Then
    ANSW = MsgBox("Möchten Sie ein Rückenschild anlegen?", vbQuestion + vbYesNo, " Rückenschild anlegen")
    If ANSW = 7 Then Exit Sub

    boVorhanden = False
          
    For Each x3WB In Application.Workbooks
          
         If UCase(x3WB.Name) = UCase(strDATEI3NAME) Then
                boVorhanden = True
                Exit For
         End If
    Next
  
    If boVorhanden = False Then
           Set x3WB = Workbooks.Open(strDATEI3PFAD)
        Else
               Set x3WB = Workbooks(strDATEI3NAME)
    End If
  
  
    For lngCol = 1 To 17 Step 4
    x3WB.Sheets(3).Activate
   
    If x3WB.Sheets(3).Cells(2, lngCol) = "" Then
   
          x3WB.Sheets(3).Cells(2, lngCol) = Target.Offset(0, -1) & "/" & Target
       
          x3WB.Sheets(3).Cells(4, lngCol) = Target.Offset(0, 2)
          x3WB.Sheets(3).Cells(5, lngCol) = Target.Offset(0, 9)
          x3WB.Sheets(3).Cells(6, lngCol) = Target.Offset(0, 10)
          x3WB.Sheets(3).Cells(3, lngCol) = Target.Offset(0, 3)
          x3WB.Sheets(3).Cells(7, lngCol) = Target.Offset(0, 11)
          GoTo weiter2
     End If
 
      Next lngCol
  
weiter2:
       
     answDurchlauf = MsgBox("Weitere Rückenschilder hinzufügen?", vbYesNo + vbQuestion, " Anzahl Durchläufe...")
      
             If answDurchlauf = 6 Then
             Quelle.Activate
            
           
            Exit Sub
  
   End If
       

'*****
      

   If Target.Column = 4 Then

Const strDATEI2PFAD As String = "**************"
Const strDATEI2NAME As String = "*****************"
Dim xlWB As Excel.Workbook
Dim bolVorhanden As Boolean
Dim lngFreieZeile As Long
Dim lngANSW As Long

lngANSW = MsgBox("Möchten Sie eine kommissionsbedingte Arbeit anlegen?", vbQuestion + vbYesNo, "Kommissionsbedingte Arbeit anlegen")
If lngANSW = 7 Then Exit Sub
bolVorhanden = False

For Each xlWB In Application.Workbooks
If UCase(xlWB.Name) = UCase(strDATEI2NAME) Then
bolVorhanden = True
Exit For
End If

Next
If bolVorhanden = False Then
Set xlWB = Workbooks.Open(strDATEI2PFAD)
Else
Set xlWB = Workbooks(strDATEI2NAME)
End If
With xlWB.Sheets(1)

lngFreieZeile = .Cells(.Cells.Rows.Count, 12).End(xlUp).Row + 1
.Cells(lngFreieZeile, 12) = Target
.Cells(lngFreieZeile, 20) = Target.Offset(0, 5)
.Cells(lngFreieZeile, 13) = Target.Offset(0, 9)
.Cells(lngFreieZeile, 19) = Date
End With
Cancel = True
Else
Exit Sub
End If
Set xlWB = Nothing

End If
weiter1:
End Sub