AW: Loop Copy Paste - Tabellen konsolidieren
13.09.2015 20:01:25
fcs
Hallo Ani,
mit etwas Einsatz hättest du hier im Archiv sicher auch etwas passendes gefunden.
Nachfolgend ein entsprechendes Makro.
Gruß
Franz
Sub DatenKonsolidieren()
Dim wkbQ As Workbook
Dim wksQ As Worksheet
Dim ZeileQ As Long, ZeileQ1 As Long
Dim ZeileZ As Long
Dim StatusCalc As Long
Dim wksZ As Worksheet
Set wkbQ = ActiveWorkbook 'Arbeitsmappe mit den Tabellen, die konsolidiert _
werden sollen
ZeileQ1 = 2 '1. Zeile in Quellblättern mit Daten, die kopiert werden sollen _
= Zeile unterhalb der Spaltentitel
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each wksQ In wkbQ.Worksheets
Select Case wksQ.Name
Case "TabXYZ", "Tab123"
'diese Blätter nicht mit konsolidieren - Namen ggf. anpassen
Case Else
If wksZ Is Nothing Then
'1. Tabellenblatt komplett in neue Mappe kopieren
wksQ.Copy
Set wksZ = ActiveSheet
wksZ.Name = "AlleDaten"
Else
With wksQ
'letzte benutzte Zeile im Quelltabellenblatt
With .UsedRange
ZeileQ = .Row + .Rows.Count - 1
End With
If ZeileQ >= ZeileQ1 Then
'Daten kopieren
.Range(.Rows(ZeileQ1), _
.Rows(ZeileQ)).Copy wksZ.Cells(ZeileZ, 1)
End If
End With
End If
'nächste freie Zeile im Zieltabellenblatt
With wksZ.UsedRange
ZeileZ = .Row + .Rows.Count
End With
End Select
Next
'Formeln im Zielblatt durch Werte ersetzen
With wksZ.UsedRange
.Calculate
.Value = .Value
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub