per Macro BIS zur freien Zelle Mark. und copieren

Forumthread: per Macro BIS zur freien Zelle Mark. und copieren

jan

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

AW: per Macro BIS zur freien Zelle Mark. und copieren

30.07.2010 17:26:29

Tino

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

AW: per Macro BIS zur freien Zelle Mark. und copieren

30.07.2010 18:00:16

jan

Jepp , läuft klasse. Supervielen Dank

Beliebteste Forumthreads (12 Monate)

per Macro BIS zur freien Zelle Mark. und copieren

Forumthread: per Macro BIS zur freien Zelle Mark. und copieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

per Macro BIS zur freien Zelle Mark. und copieren

Forumthread: per Macro BIS zur freien Zelle Mark. und copieren

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread