Ich habe ein Problem mit der Replace Funktion. Als ich das Makro auf Office 2000 geschrieben habe funktioniert die Abrage innter 2Sekunden. Auf Office 97/XP dauert die Abfrage über 1min.
Hier mein Makro. Besten Dank für eure hilfe.
Sub Blattschutz_off()
'
' Blattschutz_off Makro
' Makro am 02.05.2002 von Egon Frei
ActiveSheet.Unprotect
End Sub
Sub Blattschutz_on()
'
' Blattschutz_on Makro
' Makro am 02.05.2002 von Egon Frei
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub ChangeDataOnClick()
Dim sBlattname(12) ' für 12 Monate
On Error GoTo ERR_HAN
sBlattname(1) = "Jan"
sBlattname(2) = "Feb"
sBlattname(3) = "Mär"
sBlattname(4) = "Apr"
sBlattname(5) = "Mai"
sBlattname(6) = "Jun"
sBlattname(7) = "Jul"
sBlattname(8) = "Aug"
sBlattname(9) = "Sep"
sBlattname(10) = "Okt"
sBlattname(11) = "Nov"
sBlattname(12) = "Dez"
CurrentSheet = ActiveSheet.Name
For i = 1 To 12
PersonalNrNeu = ActiveSheet.Cells(4, 18).Value
Worksheets(sBlattname(i)).Select
ActiveSheet.Unprotect
Worksheets(sBlattname(i)).Cells.Replace What:="????.xls", Replacement:=PersonalNrNeu & ".xls", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Worksheets(sBlattname(i)).Cells(4, 18).Value = PersonalNrNeu
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Next
Worksheets(CurrentSheet).Select
MsgBox "Die Daten aus der Stundenerfassungmappe " & PersonalNrNeu & ".xls sind jetzt geladen.", vbInformation, "INFO"
Application.StatusBar = "Fertig"
Exit Sub
ERR_HAN:
If Err.Number = 9 Then
' MsgBox "Blatt '" & sBlattname(i) & "' nicht vorhanden", vbCritical, "Fehler"
End If
Resume Next
End Sub