Laufzeitfehler '1004':
24.03.2009 17:37:52
Jakob
ich habe ein Problem mit den folgenden Makro. Bisher funktinierte er tadelos, aber seit heute bleibt er bei der Zeile "objWs.UsedRange = objWs.UsedRange.Value" mit der Fehlermeldung "Laufzeitfehler '1004': Anwendungs- oder objektdefinierter Fehler" hängen. Habt Ihr vielleicht eine Idee woran das liegen kann?
Vielen Dank.
Gruß,
Jakob
Sub BlattKopieren()
Dim strPfad As String, strName As String, strSheets() As String
Dim objWb As Workbook, objWs As Worksheet
Dim lngI As Long
Dim Feldinhalt As String
With Sheets("Eingabemaske")
strPfad = .Range("A54")
' strName = .Range("Lieferung") & " " ' & ".xls"
strName = .Range("Lieferung") ' & ".xls"
End With
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
Application.ScreenUpdating = False
Feldinhalt = ThisWorkbook.Sheets("Eingabemaske").Cells(4, 7).Value
Select Case Feldinhalt
Case Is = "PK"
For Each objWs In ThisWorkbook.Worksheets
If objWs.Name Like "PK*" Then
ReDim Preserve strSheets(lngI)
strSheets(lngI) = objWs.Name
lngI = lngI + 1
End If
Next
Case Is = "BD"
For Each objWs In ThisWorkbook.Worksheets
If objWs.Name Like "BD*" Then
ReDim Preserve strSheets(lngI)
strSheets(lngI) = objWs.Name
lngI = lngI + 1
End If
Next
Case Is = "CN"
For Each objWs In ThisWorkbook.Worksheets
If objWs.Name Like "CN*" Then
ReDim Preserve strSheets(lngI)
strSheets(lngI) = objWs.Name
lngI = lngI + 1
End If
Next
End Select
If lngI > 0 Then
ThisWorkbook.Sheets(strSheets).Copy
Set objWb = ActiveWorkbook
With objWb
For Each objWs In .Worksheets
objWs.Unprotect
objWs.UsedRange = objWs.UsedRange.Value
objWs.Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Delete
Next
Call DeleteAllNames
Application.DisplayAlerts = False
.SaveAs strPfad & strName & ".xls"
End With
End If
Application.ScreenUpdating = True
End Sub