Dreimal einfügen plus Kopieren-

Herzliche Grüße ins Forum


Sub DreimalEinfügen()
Dim Zelle As Range
For Each Zelle In Sheets("Tabelle1").Range("A1:A9")Verküzt auf 9 TabBätter
ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Sheets.Count)
With ActiveSheet
.Name = Zelle.Value
.Cells(1, 1) = Zelle.Value
.Cells(1, 2).Value = Zelle.Offset(0, 1).Value
End With
Next
End Sub

Mit diesem Makro (Danke ans Forum) füge Ich 56 Tab.ein und Beschrifte sie lt.Spalte A und B.
Alle einzufügenden Tab.sehen gleich aus und haben (bis auf den Text) den selben Aufbau.
Siehe bitte Beigefügte Datei..1 ist Liste 4 ist Muster.
Jetzt meine bitte :
A:/..Könnt ihr mir in obiges Makro ( Das Kopieren und Einfügen? ) der Muster Tab.
einfügen.
B:/..Oder ich lege alle Tab. an (Sage Alle Tab Markieren Kopiere und Füge ein)
danach sehen alle Tab. gleich aus nur die Beschriftung ist weg-.
in diesem Fall (vom Makro her wahrscheinlich der einfachere Weg)
obiges Makro bitte so einkürzen ? das es nur mehr die Beschriftung
A1 und B1 kann.
Vielen Dank für eure Hilfe
michael
https://www.herber.de/bbs/user/39965.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael,
so wird "Muster" kopiert.
Sub DreimalEinfügen()
    Dim Zelle As Range

    On Error GoTo ErrExit
    GetMoreSpeed

    For Each Zelle In ThisWorkbook.Sheets("Liste").Range("A1:A" & ThisWorkbook.Sheets("Liste").Cells(Rows.Count, 1).End(xlUp).Row)
        ThisWorkbook.Sheets("Muster").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        With ActiveSheet
            .Name = Zelle.Value
            .Cells(1, 1) = Zelle.Value
            .Cells(1, 2).Value = Zelle.Offset(0, 1).Value
        End With
    Next

    ErrExit:
    GetMoreSpeed 0
End Sub

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
    Static lngCalc As Long

    With Application
        If Modus = 1 Then
            lngCalc = .Calculation
            .ScreenUpdating = False
            .EnableEvents = False
            .DisplayAlerts = False
            .Calculation = -4135
            .Cursor = xlWait
        Else
            .ScreenUpdating = True
            .EnableEvents = True
            .DisplayAlerts = True
            .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
            .Cursor = xlDefault
        End If
    End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread