Daten über Tabellen sammeln

Hi,
folgendes Makro kopiert mir alle Daten von allen Tabellenblättern einer Datei und überträgt diese in ein Blatt WORK. Das Makro funktioniert soweit einwandfrei.
Nun möchte ich beim Übertragen, die Daten um eine Spalte verschieben. Also Spalte-1 von Quell-Blatt-1 soll nach Work Spalte-2 übertragen werden, usw...
Zusätzlich soll in WORK in jeder übertragenen Zeile in Spalte 1 der Name des Quell-Tabellenblattes stehen.
Mein Ziel ist es über die Daten aller Tabellenblätter auf einer Seite zu sammeln, damit ich eine Pivot erstellen kann. Ich möchte den Tabellenblattnamen als zusätzliches Auswahlkriterium in der Pivot haben.
Hoffe, es kann mir jemand helfen - danke - Herbi


Sub copytabelle()
' copytabelle Makro
' Makro am 11.09.2007 von htjenu aufgezeichnet
Dim wksSheets As Worksheet
Dim strTarget As String
Dim lngI As Long, lngTargetLastRow As Long
' *** Hier den Namen des Blattes angeben in das kopiert werden soll !!!!
strTarget = "Work"
If MsgBox("Wollen Sie die Daten im Tabellenblatt " & strTarget & " vorher löschen ?!", vbYesNo)  _
_
_
_
_
= vbYes Then
Sheets(strTarget).Cells.Delete
End If
Application.ScreenUpdating = False
For Each wksSheets In ActiveWorkbook.Worksheets
If wksSheets.Name  strTarget Then
For lngI = 1 To wksSheets.Cells(Rows.Count, 1).End(xlUp).Row
' If UCase(wksSheets.Cells(lngI, 1)) = UCase("realisation") Then
wksSheets.Cells(lngI, 1).EntireRow.Copy
lngTargetLastRow = Sheets(strTarget).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(strTarget).Cells(lngTargetLastRow + 1, 1).Activate
ActiveSheet.Paste
' End If
Next lngI
End If
Next wksSheets
Application.ScreenUpdating = False
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

For Each wksSheets In ActiveWorkbook.Worksheets If wksSheets.Name strtarget Then For lngI = 1 To wksSheets.Cells(Rows.Count, 1).End(xlUp).Row ' If UCase(wksSheets.Cells(lngI, 1)) = UCase("realisation") Then wksSheets.Cells(lngI, 1).EntireRow.Copy lngTargetLastRow = Sheets(strtarget).Cells(Rows.Count, 1).End(xlUp).Row Sheets(strtarget).Cells(lngTargetLastRow + 1, 1).Activate ActiveSheet.Paste Sheets(strtarget).Cells(lngTargetLastRow + 1, 1).Range("A1").Insert _ shift:=xlShiftToRight Sheets(strtarget).Cells(lngTargetLastRow + 1, 1).Value = wksSheets.Name ' End If Next lngI End If Next wksSheets

Sub copytabelle() ' copytabelle Makro ' Makro am 11.09.2007 von htjenu aufgezeichnet Dim wksSheets As Worksheet Dim strTarget As String, wksTarget As Worksheet Dim lngI As Long Dim Bereich As Range, ZeileZiel As Long, ZeileStart As Long ' *** Hier den Namen des Blattes angeben in das kopiert werden soll !!!! strTarget = "Work" Set wksTarget = Worksheets(strTarget) If MsgBox("Wollen Sie die Daten im Tabellenblatt " & strTarget & " vorher löschen ?!", _ vbYesNo) = vbYes Then Sheets(strTarget).Cells.Delete End If Application.ScreenUpdating = False ZeileZiel = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1 ZeileStart = ZeileZiel For Each wksSheets In ActiveWorkbook.Worksheets If wksSheets.Name strTarget Then With wksSheets lngI = wksSheets.Cells(Rows.Count, 1).End(xlUp).Row Set Bereich = .Range(.Cells(1, 1), .Cells(lngI, _ .Cells.SpecialCells(xlCellTypeLastCell).Column)) Bereich.Copy Destination:=wksTarget.Cells(ZeileZiel, 2) End With With wksTarget Set Bereich = .Range(.Cells(ZeileZiel, 1), .Cells(ZeileZiel + Bereich.Rows.Count - 1, 1) _ ) Bereich.Value = wksSheets.Name End With ZeileZiel = ZeileZiel + Bereich.Rows.Count End If Next wksSheets GoTo weiter 'Diese Zeile deaktivieren, wenn nur Zeilen mit "Realisation" übertragen werden _ sollen With wksTarget 'Zeilen ohne "Realisation" in Spalte 2 löschen For ZeileZiel = .Cells(.Rows.Count, 1).End(xlUp).Row To ZeileStart Step -1 If UCase(.Cells(ZeileZiel, 2)) UCase("realisation") Then .Rows(ZeileZiel).Delete Shift:=xlShiftUp End If Next ZeileZiel End With weiter: Application.ScreenUpdating = False End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread