AW: Daten aus Tabellen in Übersicht zusammenfassen
24.09.2013 13:37:59
fcs
Hallo Daniel,
hier die Hilfeleistung
Gruß Franz
Sub Uebersicht_erstellen()
Dim wksUeb As Worksheet, wksQ As Worksheet
Dim lngZeileUeb As Long, lngZeileQ As Long
Dim lngZeile As Long, lngSpalte As Long, lngSpalteUeb As Long, strText As String
Dim bolLoeschen As Boolean, Zeile1 As Long, StatusCalc As Long
Set wksUeb = ActiveWorkbook.Worksheets("Tabelle3")
Zeile1 = 2 '1. Zeile mit zu kopierenden/einzufügenden Daten
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
With wksUeb
'Altdaten in Übersicht löschen
lngZeileUeb = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeileUeb >= Zeile1 Then
.Range(.Rows(Zeile1), .Rows(lngZeileUeb)).Delete
End If
End With
'Datenzeilen aus den Quellblättern in die Übersicht kopieren
For Each wksQ In ActiveWorkbook.Worksheets
With wksQ
Select Case .Name
Case wksUeb.Name
'do nothing
Case Else
lngZeileQ = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeileQ >= Zeile1 Then
With wksUeb
lngZeileUeb = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
.Range(.Rows(Zeile1), .Rows(lngZeileQ)).Copy _
Destination:=wksUeb.Cells(lngZeileUeb, 1)
End If
End Select
End With
Next wksQ
With wksUeb
'letzte Zeile in Übersicht
lngZeileUeb = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeileUeb >= Zeile1 Then
'Letzte Spalte mit Inhalt ermitteln
With .Cells
lngSpalteUeb = .Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
End With
'Inhalte aus allen Spalten inklusive Trennzeichen verketten _
und in Hilfsspalte 1 eintragen
For lngZeile = Zeile1 To lngZeileUeb
strText = .Cells(lngZeile, 1).Text
For lngSpalte = 2 To lngSpalteUeb
strText = strText & "|" & .Cells(lngZeile, lngSpalte).Text
Next lngSpalte
.Cells(lngZeile, lngSpalteUeb + 1) = strText
Next lngZeile
'Formel zur Ermittlung der mehrfach vorkommenden Einträge in 2. Hilfsspalte _
einfügen und durch Werte ersetzen
With .Range(.Cells(Zeile1, lngSpalteUeb + 2), .Cells(lngZeileUeb, lngSpalteUeb + 2))
.FormulaR1C1 = "=COUNTIF(R2C[-1]:RC[-1],RC[-1])"
.Calculate
.Value = .Value
End With
'Zeileninhalte in doppelten Zeilen löschen
For lngZeile = Zeile1 To lngZeileUeb
If .Cells(lngZeile, lngSpalteUeb + 2) 1 Then
.Rows(lngZeile).ClearContents
bolLoeschen = True
End If
Next lngZeile
'Leerzeilen löschen
If bolLoeschen = True Then
With .Range(.Cells(Zeile1, lngSpalteUeb + 2), .Cells(lngZeileUeb, lngSpalteUeb + 2))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End With
End If
'Hilfsspalten wieder löschen
With .Range(.Columns(lngSpalteUeb + 1), .Columns(lngSpalteUeb + 2))
.Clear
End With
'Daten in Übersicht sortieren
lngZeileUeb = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeileUeb > Zeile1 Then
With .Range(.Cells(Zeile1 - 1, 1), .Cells(lngZeileUeb, lngSpalteUeb))
.Sort key1:=.Cells(1, 1), Order1:=xlAscending, _
key2:=.Cells(1, 2), Order2:=xlAscending, _
key3:=.Cells(1, 3), Order3:=xlAscending, Header:=xlYes
End With
End If
Else
MsgBox "es wurden keine Daten kopiert!"
End If
End With 'wksUeb
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub