Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1188to1192
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellenblatt kopieren (Code überprüfen)

Tabellenblatt kopieren (Code überprüfen)
Jakob
Hallo,
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
ich sehe kein Problem
06.12.2010 16:27:10
Tino
Hallo,
das von Dir erwähnte sollte in dieser Schleife geschehen.
      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
Ich sehe da jetzt aber kein Problem, außer die Zeile
objWs.Range("A1:H57") = objWs.Range("A1:H57").Value
die ist eigentlich unnötig, weil dies schon im Usedrange drin steckt.
Vielleicht würde eine Beispieldatei helfen wo dieser Fehler auftritt.
Gruß Tino
Anzeige
AW: ich sehe kein Problem
06.12.2010 17:15:25
Jakob
Hallo Tino,
ja die Zeile objWs.Range("A1:H57") = objWs.Range("A1:H57").Value
war vorher auch auskommentiert. Ich dachte es liegt daran und deshalb habe ich die Kommentierung wieder aufgehoben. Ich hatte auch in der letzten Woche nichts am Code geändert und wie gesagt am Freitag funktionierte es noch. Jetzt läuft der Code durch aber die Formeln sind noch drinnen. Dadurch dass die definierten Namen gelöscht wurden, steht nur noch #NAME?. Ich werde es heute abend bei mir zu Hause auf den Rechner versuchen. Ich gebe dann Bescheid wie es gelaufen ist.
Gruß,
Jakob Freitag
Anzeige
mach mal On Error Resume Next raus...
06.12.2010 17:21:42
Tino
Hallo,
eventuell kann es aber auch sein das Du ein Blattschutz drin hast mit einem Kennwort.
Mach mal das On Error Resume Next raus, vielleicht kommen wir dann dem Phänomen auf die Schliche.
Gruß Tino

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige