Formeln und Code sollen nicht mit kopiert werden

Public Sub Auslagern() Application.ScreenUpdating = False Worksheets("Turnierbericht").Visible = True Worksheets(Array("Obedience", "WKKlasseBeginner", "WKKlasse1", "WKKlasse2", "WKKlasse3", " _ IdentListe", "TurnierBericht")).Copy ActiveWorkbook.SaveAs "C:\Obedience\PSV1912Nbg\Daten\" & UserForm2.TextBox1.Value & "-" & _ Date ActiveWorkbook.Close ThisWorkbook.Saved = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Public Sub Auslagern0() Dim wbkA As Workbook, strBL, ii As Integer ' Application.ScreenUpdating = False ' Worksheets("Turnierbericht").Visible = True Set wbkA = ActiveWorkbook ' strBL = Array("Obedience", "WKKlasseBeginner", "WKKlasse1", "WKKlasse2", _ "WKKlasse3", "IdentListe", "TurnierBericht") strBL = Array("abc", "ddd", "hhh") Workbooks.Add xlWBATWorksheet For ii = 0 To UBound(strBL) If ii > 0 Then Worksheets.Add after:=Sheets(Worksheets.Count) ActiveSheet.Name = strBL(ii) wbkA.Sheets(strBL(ii)).Rows.Copy With Cells(1, 1) .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteValues End With Cells(1, 1).Select Next ii Application.CutCopyMode = False ' Application.ScreenUpdating = False ' ActiveWorkbook.SaveAs "C:\Obedience\PSV1912Nbg\Daten\" & _ UserForm2.TextBox1.Value & "-" & Date ' ActiveWorkbook.Close ' ThisWorkbook.Saved = True End Sub

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

Beliebteste Forumthreads (12 Monate)

Formeln und Code sollen nicht mit kopiert werden

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Formeln und Code sollen nicht mit kopiert werden

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

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread