|
Hallo!
Komme erst jetzt zum Antworten. War noch auf der Suche, das Kopieren beim Filter zu vereinfachen. Hab aber bisher nix gefunden. Musste deshalb was herkömmliches basteln. Geht vllt. auch einfacher aber auf die schnelle hat das zumindest geklappt. Einige Sachen kannst du einstellen, habe da Kommentare zu gemacht. Das Programm schaut ab Zeile10 die Zeilen durch und überträgt die eingeblendeten
Schönes Wochenende noch
Option Explicit
Sub einfügen()
'keine Prüfung, ob es so viele Blätter überhaupt gibt
Dim ende As Long
Dim i As Long
Dim zeile As Long
Dim start
Dim ziel
Dim eingeblendet As Long
Dim eintrag As Long
Application.ScreenUpdating = False
Set ziel = Worksheets(1)
eintrag = 1 'ab da wird im Blatt 2 eingetragen
For i = 5 To 23 'Blätter 5 bis 23
zeile = 10 'ab da wird der Filter ausgelesen. in Zeile 9 war der Filtrer gesetzt
eingeblendet = 1
ende = Intersect(Worksheets(i).UsedRange.SpecialCells(xlVisible), Worksheets(i).Columns(1)).Count
If ende > 1 Then
While eingeblendet < ende
If ActiveSheet.Rows(zeile).Hidden <> True Then
Worksheets(i).Range(Worksheets(i).Cells(zeile, 1), Worksheets(i).Cells(zeile, 10)).Copy ziel.Cells(eintrag, 1)
ziel.Cells(eintrag, 11) = Worksheets(i).Name
eingeblendet = eingeblendet + 1
eintrag = eintrag + 1
End If
zeile = zeile + 1
Wend
End If
eintrag = eintrag + 1
Next i
Application.ScreenUpdating = True
Set ziel = Nothing
End Sub
|