Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1212to1216
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro für die personl.xls abändern

Makro für die personl.xls abändern
WalterK
Hallo,
den folgenden Code habe ich in der Recherche gefunden und er entspricht fast dem, was ich auch bräuchte. Er legt ein neues Blatt an, vergibt einen Namen und kopiert einen Bereich vom aktiven Blatt in das neue Blatt.
Kann mir jemand die notwendigen Änderungen im Code durchführen:
1.) Den Code habe ich in der personl.xls platziert und starte ihn mit einer Schaltfläche in der Symbolleiste. Allerdings wird jetzt in der personl.xls ein neues Blatt angelegt. Das sollte aber in meiner gerade aktiven Mappe passieren. Zur Info: Ich weiß nie, wie die Quelltabelle heißt.
2.) Die Spaltenbreite sollte auch mitgegeben werden.
3.) In der Zeile 1 sollten die Formeln erhalten bleiben.
Hier noch der Code:
Option Explicit
Sub Blattanlegen()
Dim objSh As Worksheet, objShNew As Worksheet
Dim intCol As Integer, intMax As Integer
Dim lngRow As Long, lngMax As Long
Set objSh = ActiveSheet
With objSh
For intCol = 3 To Columns.Count
lngMax = Application.Max(lngMax, .Cells(Rows.Count, intCol).End(xlUp).Row)
Next
For lngRow = 2 To lngMax
intMax = Application.Max(intMax, .Cells(lngRow, Columns.Count).End(xlToLeft).Column)
Next
Set objShNew = ThisWorkbook.Worksheets.Add(after:=objSh)
objShNew.Name = "NEU " & Format(Now, "dd/mm/yyyy hhmmss")
.Range(.Cells(1, 1), .Cells(lngMax, intMax)).Copy objShNew.Range("A1")
End With
Set objSh = Nothing
Set objShNew = Nothing
End Sub
Besten Dank für die Hilfe und Servus, Walter

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
ActiveWorkbook
14.05.2011 10:23:55
Matthias
Hallo
ungetestet
statt:
Set objShNew = ThisWorkbook.Worksheets.Add(after:=objSh)
versuche:
Set objShNew = ActiveWorkbook.Worksheets.Add(after:=objSh)
ThisWorkbook ist die Mappe in der der Code steht!
Gruß Matthias
AW: ActiveWorkbook
14.05.2011 11:07:55
WalterK
Hallo Matthias,
dieser Teil klappt jedenfalls schon mal, besten Dank dafür.
Hast Du für die Punkte 2 und 3 auch noch eine Lösung?
Zudem hat sich noch etwas ergeben: Auch die Einstellungen unter "Seite einrichten" wie z.B. Querformat, Normalgröße 80 %, Kopf- und Fußzeile sollten auch ins neue Blatt übernommen werden.
Besten Dank, Servus Walter
Anzeige
warum nicht ganze Tabelle kopieren?
14.05.2011 14:19:51
Tino
Hallo,
kopiere doch einfach die gesamte Tabelle und benenne diese um,
dann sollte alle einstellungen erhalten bleiben.
Sub Blattanlegen()
With ActiveWorkbook
.ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
.ActiveSheet.Name = "NEU " & Format(Now, "dd/mm/yyyy hhmmss")
End With
End Sub
Gruß Tino
AW: warum nicht ganze Tabelle kopieren?
14.05.2011 14:45:41
WalterK
Hallo Tino,
das mit der "ganzen Tabelle" geht eben nicht, weil die sogenannte Quelltabelle eine Menge zusätzliche Auswertungsspalten hat. Diese zusätzlichen Spalten benötige ich als Grundlage für den Autofilter. Für die gefilterten Daten lege ich dann die neuen Blätter an. Und in den neuen Blättern benötige ich nur die Spalten A bis intMax.
Danke und Servus, Walter
Anzeige
im Ziel Spalten und Zeilen löschen
14.05.2011 15:36:52
Tino
Hallo,
dann lösche doch die nicht benötigten Zeilen und Spalten erst im Ziel.
Sub Blattanlegen()
Dim lngCol&, lngRow&, lngMaxRow&, lngMaxCol&

With ActiveWorkbook
    With .ActiveSheet
        For lngCol = 3 To Application.Max(.UsedRange.Columns.Count, 3)
            lngMaxRow = Application.Max(lngMaxRow, .Cells(.Rows.Count, lngCol).End(xlUp).Row)
        Next
        
        For lngRow = 2 To lngMaxRow
            lngMaxCol = Application.Max(lngMaxCol, .Cells(lngRow, .Columns.Count).End(xlToLeft).Column)
        Next
    End With
        
        .ActiveSheet.Copy After:=.Sheets(.Sheets.Count)
    
    With .ActiveSheet
        .Range(.Cells(1, lngMaxCol + 1), .Cells(1, .Columns.Count)).EntireColumn.Delete
        .Range(.Cells(lngMaxRow + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
        .Name = "NEU " & Format(Now, "dd/mm/yyyy hhmmss")
    End With
End With
End Sub
Gruß Tino
Anzeige
Gute Idee! Besten Dank Tino ....
14.05.2011 16:23:30
WalterK
Hallo,
... es funktioniert bestens.
Servus, Walter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige