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
|