Makro läuft nur einmal
02.02.2009 17:58:00
Heinz
Ich habe einen externen Sheets z.B. "20090W6" oder "2009W06B" usw.. (2009 ist das Jahr) "(W06 ist die Kalenderwoche)
Die Werte von diesen Sheets werden mir in die Arbeitsmappe "Gewichtsblätter & Wochenumbau-test.xls" eingetragen.
Soweit funktioniert auch alles.
Wenn ich den CommandButton2 2 mal hintereinander anklicke funkt. das untere Makro nicht. Ich muss zuerst meine Arbeitsmappe schliessen und wieder öffnen,dann funkt. es wieder, aber nur einmal.
Weiss jemand woran das liegen kann ?
Gruß Heinz
Option Explicit
'---- Planänderung -----
Private Sub CommandButton2_Click()
Sheets("Wochenplan").Unprotect Password:="test"
Windows.Application.ScreenUpdating = False
Dim wb1 As Workbook, wbKW As Workbook, wksKW As Worksheet
Set wb1 = Workbooks("Gewichtsblätter & Wochenumbau-test.xls")
For Each wbKW In Workbooks
' If Left(wbKW.Name, 2) = "KW" Then Exit For
If wbKW.Name Like "*W*" And Left(wbKW.Name, 1) "W" Then Exit For
Next
If wbKW Is Nothing Then
MsgBox "Es ist kein Wochenplan zu Verfügung !"
Sheets("Wochenplan").Protect Password:="test"
Exit Sub
End If
For Each wksKW In wbKW.Worksheets
'If Left(wksKW.Name, 2) = "KW" Then
If wksKW.Name Like "[0-9]*[W][0-9]*" Then
wksKW.Copy Before:=wb1.Sheets(1)
' wksKW.Copy Before:=wbThis.Sheets(1)
Exit For
End If
Next
Dim wks As Worksheet
For Each wks In Worksheets
'If wks.Name Like "KW*" Then
If wks.Name Like "[0-9]*[W][0-9]*" Then
' KW Einfügen
Range("A62") = Left(wks.Range("J3").Value, 7)
'Linie 311--------
Range("F65") = Left(wks.Range("C5").Value, 5) 'Sonntag Linie 311
'Leerzeichen löschen
Range("F65:AL110").Replace What:=" ", Replacement:="", LookAt:=xlPart
Range("A62").Replace What:="(", Replacement:="", LookAt:=xlPart
Dim sh As Object
For Each sh In Sheets
If sh.Name Like "*W*" And Left(sh.Name, 1) "W" Then
'If sh.Name Like "KW*" Or sh.Name Like "KW*" Then
'If sh.Name Like "*KW*" Or sh.Name Like "*KW*" Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next
Windows.Application.ScreenUpdating = True
Exit For
End If
Next
Sheets("Wochenplan").Protect Password:="test"
End Sub