Worksheet in anderes Workbook kopieren und unbenennen

09/06/2010 - 17:21 von Tinu Kiefer | Report spam
Guten Tag

Ziel: Standardarbeitsmappe in neue Datei kopieren und anschliessend
umbenennen.
Fehlermeldung: Objekt unterstützt diese Eigenschaft nicht.

Vielen Dank für Tipps und Tricks!

Sub CopySheet()
Dim intAnzahl As Integer
Dim intZaehler As Integer
Dim wbkQuelle As Workbook
Dim wbkZiel As Workbook
Dim wksQuelle As Worksheet

Set wbkQuelle = Workbooks("Einsatzplandef.xls")
Set wbkZiel = Workbooks("arbeitskopie.xls")
Set wksQuelle = wbkQuelle.Worksheets("Parzblatt")

intAnzahl = CInt(Sheets("Parzelle").Cells(3, 4)) ' Anzahl auf Sheet 1,
Zelle A1
intAnzahl = intAnzahl + 7
For intZaehler = 5 To intAnzahl
wksQuelle.Copy after:=wbkZiel.Sheets(wbkZiel.Sheets.Count)
wbkZiel.Sheets(wbkZiel.Sheets.Count).Name wbkQuelle.wksQuelle.Cells(intZaehler, 2)


Next intZaehler


End Sub
 

Lesen sie die antworten

#1 Andreas Killer
09/06/2010 - 18:58 | Warnen spam
Tinu Kiefer schrieb:

Ziel: Standardarbeitsmappe in neue Datei kopieren und anschliessend
umbenennen.
Fehlermeldung: Objekt unterstützt diese Eigenschaft nicht.


...
wbkZiel.Sheets(wbkZiel.Sheets.Count).Name > wbkQuelle.wksQuelle.Cells(intZaehler, 2)



wksQuelle ist keine Eigenschaft des wbkQuelle WorkBook-Objects.

Der Versuch es so zu referenzieren ist zwar gut gemeint, aber unnötig,
weil ein Object generell weiß zu wem es gehört.

Im Übrigen ist das kopieren von Sheets ein wenig aufwendiger, es gibt
da ein paar gemeine Limits.

Zumal Du so recht schnell Gefahr làufst das das umbenennen
fehlschlàgt, weil der Name ungültig ist, das Sheet schon existiert...

Ich kopier Dir mal ein paar Routinen.

Andreas.

Option Explicit

Function ValidSheetName(ByVal SheetName As String) As String
'Entfernt ungültige Zeichen aus Sheetname
Const InvalidChars = ":\/?*[]"
Dim I As Integer
For I = 1 To Len(InvalidChars)
SheetName = Replace(SheetName, Mid(InvalidChars, I, 1), "")
Next
ValidSheetName = Mid(SheetName, 1, 31)
End Function

Function NewSheetName(ByVal SheetName As String) As String
'Gibt einen nicht existierenden Tabellenblattnamen zurück _
der mit SheetName beginnt
Dim I As Integer, NewName As String, SheetExt As String
SheetName = ValidSheetName(SheetName)
NewName = SheetName
If SheetExists(SheetName) Then
I = 0
Do
I = I + 1
SheetExt = " (" & I & ")"
If Len(SheetName) + Len(SheetExt) > 31 Then SheetName = _
Mid(SheetName, 1, 31 - Len(SheetExt))
NewName = SheetName & SheetExt
Loop Until Not SheetExists(NewName)
End If
NewSheetName = NewName
End Function

Function SheetExists(ByVal SheetName As String, Optional WB As _
Workbook = Nothing) As Boolean
'Prüft ob das Tabellenblatt SheetName existiert
Dim S As Worksheet
If WB Is Nothing Then Set WB = ActiveWorkbook
On Error GoTo ExitPoint
Set S = WB.Sheets(SheetName)
SheetExists = True
ExitPoint:
End Function

Sub CopySheets(Optional ByVal OldBook As Workbook = Nothing, _
Optional ByVal NewBook As Workbook = Nothing, Optional ByVal _
SheetName As String = "*", Optional ByVal OverWriteSheets As _
Boolean = True)
'Kopiert die gewünschten Sheets von Mappe OldBook nach Mappe _
NewBook
Dim S As Variant, C As Range, B As Shape, I As Long
Dim OldName As String, AfterSheet As Integer, TempSheet As _
Worksheet

If OldBook Is Nothing Then Set OldBook = ActiveWorkbook
OldName = OldBook.Name

If NewBook Is Nothing Then Set NewBook = Workbooks.Add
If NewBook Is OldBook Then Exit Sub

Application.ScreenUpdating = False
Set TempSheet = Nothing
For Each S In OldBook.Sheets
If S.Name Like SheetName Then
'Tabellen nacheinander kopieren
AfterSheet = NewBook.Sheets.Count
If OverWriteSheets Then
If SheetExists(S.Name, NewBook) Then
If NewBook.Sheets.Count = 1 Then Set TempSheet = _
NewBook.Sheets.Add
AfterSheet = NewBook.Sheets(S.Name).Index - 1
DeleteSheet S.Name, NewBook
End If
End If
If AfterSheet = 0 Then
S.Copy Before:=NewBook.Sheets(AfterSheet + 1)
Else
S.Copy after:=NewBook.Sheets(AfterSheet)
End If

Select Case TypeName(S)
Case "Worksheet"
For Each C In S.UsedRange
With NewBook.Sheets(S.Name).Cells(C.Row, C.Column)
If C.HasFormula Then
If Len(C.Formula) > 255 Then .Formula = C.Formula
Else
If Len(C.Value) > 255 Then .Value = C.Value
End If
End With
Next
Case "Chart"
'Okay
End Select
End If
Next
If Not TempSheet Is Nothing Then DeleteSheet TempSheet.Name, _
NewBook

For Each S In NewBook.Sheets
Select Case TypeName(S)
Case "Worksheet"
'Formeln korrigieren
For Each C In S.UsedRange
If C.HasFormula Then C.Formula = Replace(C.Formula, _
"[" & OldName & "]", "")
Next
'Button's korrigieren
For Each B In S.Shapes
If Len(B.OnAction) > 0 Then B.OnAction = NewBook _
.Name & Mid(B.OnAction, InStr(B.OnAction, "!"))
Next
Case "Chart"
For I = 1 To S.SeriesCollection.Count
With S.SeriesCollection(I)
.Formula = Replace(.Formula, "[" & OldName & "]", "")
End With
Next
End Select
Next

Sheets(OldBook.ActiveSheet.Name).Select
Application.ScreenUpdating = True
End Sub

Sub DeleteSheet(Optional ByVal SheetName As String = "", _
Optional WB As Workbook = Nothing)
'Löscht das angegebene Tabellenblatt
Dim Alerts As Boolean
If WB Is Nothing Then Set WB = ActiveWorkbook
If SheetName = "" Then SheetName = WB.ActiveSheet.Name
'Es muss immer mind. 1 Tabellenblatt vorhanden sein
If WB.Sheets.Count = 1 Then WB.Sheets.Add
'Fehlermeldungen ausschalten
Alerts = Application.DisplayAlerts
Application.DisplayAlerts = False
'Fehlerbehandlung aus, falls SheetName nicht existiert
On Error Resume Next
WB.Sheets(SheetName).Delete
On Error GoTo 0
Application.DisplayAlerts = Alerts
End Sub

Ähnliche fragen