Hallo again :-)
Hatte schon gar nicht mehr mit einer Rückmeldung gerechnet.
In der Hoffnung, dass dein Anliegen richtig rübergekommen ist,
müsste das etwa folgendermaßen aussehen. Für VBA-Anfänger gibt
es noch ein paar Kommentare extra :-)
Sub Kopieren()
' Dein äußerer With-Block (ActiveWorkbook) ist überflüssig,
' weil sich Workshhet ohne vorangestellten Objektbezeichner
' sowieso immer auf die aktive Arbeitsmappe bezieht.
' Zu deinem inneren With-Block (UsedRange): Man kann With-
' Blöcke zwar verschachteln, muss dann aber im inneren
' Block alle Bezüge auf den äußeren Block vollständig
' adressieren, weil Excel im inneren Block keine Elemente
' des äußeren "sieht".
Dim wksSource As Worksheet ' zu kopierende Tabelle
Dim wksDestination As Worksheet ' Zieltabelle
Dim rngSource As Range ' zu kopierender Bereich
' Den Zielbereich müssen wir nicht extra deklarieren, weil als
' Zielangabe die linke obere Zelle dieses Bereiches genügt.
Dim i As Long ' Laufvariable
Dim lz As Long ' letzte Zeile
Dim ls As Integer ' letzte Spalte
' Zeilen sind immer Long, Spalten Integer (außer Excel 2007)
Set wksDestination = Worksheets.Add(After:=Worksheets( _
Worksheets.Count))
wksDestination.Name = Format(Date, "dd.mm.yyyy")
' Zur Sheets-Auflistung gehören außer Tabellen auch Diagramme.
' 'Sheets' klappt also nur wenn es keine Diagramme gibt.
Worksheets(4).Rows(3).Copy Destination:=wksDestination. _
Range("A1")
' wäre dir die Titelzeile in Fettschrift recht?
wksDestination.Rows(1).Font.Bold = True
For i = 3 To Worksheets.Count - 1
' - 1: Das letzte Blatt nicht in die Schleife einbeziehen,
' sonst gibt es wieder Dubletten.
Set wksSource = Worksheets(i)
With wksSource
lz = .UsedRange.Rows(.UsedRange.Rows.Count).Row + 1
ls = .UsedRange.Columns(.UsedRange.Columns.Count).Column
' Das sieht zwar recht umständlich aus, funktioniert aber auch,
' wenn der genutzte Bereich ungleichmäßig gefüllt ist.
Set rngSource = .Range(.Cells(4, 1), .Cells(lz, ls))
End With
lz = wksDestination.UsedRange.Rows(wksDestination. _
UsedRange.Rows.Count).Row
rngSource.Copy Destination:=wksDestination.Cells(lz + 1, 1)
Next i
End Sub
Wenn es Probleme gibt melde dich noch mal.
Gruß
|