per Macro BIS zur freien Zelle Mark. und copieren

Hi @ All,
ich würde gerne Datenbereiche mehrerer Tabellenblätter innerhalb einer Datei zusammenkopieren um als Datenbasis für eine Pivot-Tabelle zu fungieren. Meine Arbeitsblätter sind von oben alle gleich aufgebaut, enden jedoch in unterschiedlichen zeilen. Ich stelle mir einen Code vor der der im ersten Blatt die Daten ab bspweise A15 bis f? (hier eben erste leere Zeile) markiert und in fest benanntes Tabellenblatt kopiert bsp "Datenpool". Dann das nächste Tabellenblatt auch wieder ab a15 bis f ?, die Daten markieren und an die Daten in Datenpool anhängen.
Die Tebellenblätter haben alle feste Namen
Das Resultat wäre ein großer Datenpool auf den ich leicht eine Pivot beziehen kann.
Viel verlangt, ich weiß aber evtl kann mir ja einer helfen ?
Großer Dank vorab schon einmal
Jan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
kannst ja mal testen.
Die Ausnahmeliste müsstest Du noch anpassen.

Function FindMaxRow(rngBereich As Range) As Long
Dim LRow As Long
On Error Resume Next
LRow = rngBereich.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
LRow = Application.Max(LRow, rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
FindMaxRow = LRow
End Function

Sub Zusammen_Fassen()
Dim oWS As Worksheet, New_WS As Worksheet
Dim MaxRow As Long, merkRow As Long, rngBereich As Range
Dim ArNot_Tab
Set New_WS = Sheets.Add(After:=Sheets(Sheets.Count))

'Ausnahmeliste 
'die Tabellen die nicht verwendet werden sollen 
ArNot_Tab = Array("Tabelle1", "Tabelle6", New_WS.Name)

merkRow = 2 'erste Zeile 

For Each oWS In Worksheets
    'prüfen ob Tabelle in Ausnahmeliste 
    If Not IsNumeric(Application.Match(oWS.Name, ArNot_Tab, 0)) Then
        With oWS
            Set rngBereich = .Range(.Cells(15, 1), .Cells(.Rows.Count, 6))
            MaxRow = FindMaxRow(rngBereich)
            If MaxRow > 0 Then
                Set rngBereich = .Range(.Cells(15, 1), .Cells(MaxRow, 6))
                rngBereich.Copy New_WS.Cells(merkRow, 1)
                merkRow = merkRow + rngBereich.Rows.Count
            End If
        End With
    End If
Next oWS

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

per Macro BIS zur freien Zelle Mark. und copieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

per Macro BIS zur freien Zelle Mark. und copieren

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

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread