man nicht mehrere sheets kopieren kann.
mit der Funktion MySheetCopy kann ich dieses Problem
umgehen (siehe unten). Aber der Zähler für neue Mappen
geht in die höhe. Weiss jemand wie man das rücksetzen kann.
Ohne excel zu beenden oder zu speichern.
Ich habe nämlich Dateien die sind ca. 4MB gross und das Speichern
dauert ewig.
Danke
Function DoSheetExist(ByVal wkb2CheckSheet As Workbook, Optional sht2Check As Worksheet, Optional Name2Check As String) As Boolean
' Funktion überprüft ob eine Tabelle in einer Arbeitsmappe
' bereits besteht Parameter Tabelle kann entweder als name
' oder als worksheet objekt übergeben werden
Dim i As Worksheet
Dim HlpStr As String
DoSheetExist = False
If sht2Check Is Nothing Then
HlpStr = Name2Check
Else
HlpStr = sht2Check.Name
End If
For Each i In wkb2CheckSheet.Worksheets
If i.Name = HlpStr Then
DoSheetExist = True
Exit Function '!!!!!!!!!
End If
Next i
End Function
Function MySheetCopy(Optional ParAfter As Variant = -1)
' Da Excel immer beim Kopieren Fehler 1004 nach einigen malenliefert
' diese Funktion
Dim TmpWrkbook As Workbook
Dim TmpSht As Worksheet
Dim HlpCnt As Integer
HlpCnt = 1
Set TmpWrkbook = ActiveWorkbook
Set TmpSht = ActiveSheet
TmpSht.Copy
'Sheets.Copy
Do
HlpCnt = HlpCnt + 1
Loop While DoSheetExist(TmpWrkbook, , ActiveSheet.Name + "(" + Format(HlpCnt) + ")")
ActiveSheet.Name = ActiveSheet.Name + "(" + Format(HlpCnt) + ")"
On Error Resume Next
If ParAfter <> -1 Then
ParAfter = ParAfter
Else
Set ParAfter = TmpSht
End If
On Error GoTo 0
Sheets(1).Move After:=ParAfter
End Function
Sub testMySheetCopy()
Dim HlpSheet As Worksheet
Dim HlpCnt As Integer
For HlpCnt = 1 To 200
Set HlpSheet = ActiveSheet
MySheetCopy ParAfter:=Sheets(Sheets.Count)
HlpSheet.Select
Next HlpCnt
End Sub