Formeln und Code sollen nicht mit kopiert werden

Hallo Peter,
probier mal


Option Explicit
Public Sub Auslagern2()
Dim wbkA As Workbook, strBL, ii As Integer, lngL As Long, rng As Range, jj As Integer
Application.ScreenUpdating = False
Worksheets("Turnierbericht").Visible = True
Set wbkA = ActiveWorkbook
strBL = Array("Obedience", "WKKlasseBeginner", "WKKlasse1", "WKKlasse2", "WKKlasse3", _
"IdentListe", "TurnierBericht")
Workbooks.Add xlWBATWorksheet
For ii = 0 To UBound(strBL)
If ii > 0 Then Worksheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = strBL(ii)
With wbkA.Sheets(strBL(ii))
Set rng = .Cells.Find("*", .Cells(1, 1), xlValues, , xlByRows, xlPrevious)
If rng Is Nothing Then lngL = 1 Else lngL = rng.Row
ReDim hh(1 To lngL)
For jj = 1 To lngL
hh(jj) = .Rows(jj).RowHeight
Next jj
.Columns.Copy
End With
With Range("A1")
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
For jj = 1 To lngL
Rows(jj).RowHeight = hh(jj)
Next jj
Cells(1, 1).Select
Next ii
Application.ScreenUpdating = False
ActiveWorkbook.SaveAs "C:\Obedience\PSV1912Nbg\Daten\" & _
UserForm2.TextBox1.Value & "-" & Date
ActiveWorkbook.Close
ThisWorkbook.Saved = True
End Sub

Das Ganze ginge etwas schneller, wenn man statt der Spalten die (vielen) Zeilen kopiert
und die Spaltenbreiten nachher überträgt. Momentan ist es gerade umgekehrt (hatte ich schon).
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hallo Peter,
ungetestet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Sub Auslagern()
Dim objWs As Worksheet

On Error GoTo ErrExit
GMS

Worksheets("Turnierbericht").Visible = True

Worksheets(Array("Obedience", "WKKlasseBeginner", "WKKlasse1", "WKKlasse2", "WKKlasse3", "IdentListe", "TurnierBericht")).Copy

With ActiveWorkbook

    For Each objWs In .Worksheets
        'Formeln in Werte umwandeln
        objWs.UsedRange = objWs.UsedRange.Value

        'Code entfernen
        With .VBProject.VBComponents(objWs.CodeName).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
    Next

    .SaveAs "C:\Obedience\PSV1912Nbg\Daten\" & UserForm2.TextBox1.Value & "-" & Date
    .Close
End With

ThisWorkbook.Saved = True

ErrExit:
GMS True
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Formeln und Code sollen nicht mit kopiert werden

Forumthread: Formeln und Code sollen nicht mit kopiert werden

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Formeln und Code sollen nicht mit kopiert werden

Forumthread: Formeln und Code sollen nicht mit kopiert werden

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread