den folgeden Code hatte ich mit Eurer Hilfe nach und nach vervollständig. Der Code soll alle Tabellenbläter der Datei deren Tabellenblattname (ersten 2 Buchstaben) mit den Wert aus der zelle G4(Tabellenblatt "Eingabemaske") übereinstimmt in ein neues Tabellenblatt kopieren. Darüberhinaus löscht er die Schaltflächen und die definierten Namen und speichert es als neue Datei unter den Pfad der in Zelle
A54 (Tabellenblatt "Eingabemaske") angegeben ist. Bevor die definierten Namen gelöscht werden sollten die Formeln durch Werte ersetzt werden. Das hat jetzt jahrelang (bis letzten Freitag) funktioniert. Seit heute klappt es nicht mit den Formeln durch Werte ersetzen. Da meine VBA-Kenntnisse mehr als bescheidend sind (nur mit Makrorecorder), kann ich die betreffende Stelle im Code nicht identifizieren.
Könntet Ihr Euch bitte mal den Code anschauen und mir evtl. sagen warum das jetzt nicht mehr _ funktioniert?
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"
End With
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
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
Case Is = "DZ"
For Each objWs In ThisWorkbook.Worksheets
If objWs.Name Like "DZ*" 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
On Error Resume Next
For Each objWs In .Worksheets
objWs.Unprotect
objWs.UsedRange = objWs.UsedRange.Value
objWs.Range("A1:H57") = objWs.Range("A1:H57").Value
objWs.Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Delete
Next
On Error GoTo 0
Call DeleteAllNames
Application.DisplayAlerts = False
.SaveAs strPfad & strName & ".xls"
End With
End If
Application.ScreenUpdating = True
End Sub
Vielen Dank schon mal.
Gruß,
Jakob Freitag