AW: Tabellen vergleichen - Makro-Lösung
22.11.2019 14:21:45
fcs
Hallo Andrea,
mit dem nachfolgenden Makro werden die Daten in eine per Pivot auswertbare Form umgestellt und dann ein Pivottabellenbericht generiert.
Voraussetzung ist hier, dass die Werte Zahlen sind.
das Makro kannst du in ein allgemeines Modul in deiner persönliche Makroarbeitsmappe übernehmen.
Wenn du die Tage alle nebeneinander haben willst, dann kannst du das Feld Datum auch al1 1. Feld in den Spaltenbereich verschieben.
Ansonsten muss du mal probieren, welche Anordnung der Felder ID. Datum und Tabelle die günstigste Anordnung für einen Vergleich liefert - Danach kann man dann das Makro noch etwas anpassen.
LG
Franz
Sub Vergleichstabelle_erstellen_2()
'Auswertung via Pivotbericht
Dim iWs As Integer, Zeile_L As Long, Zeile As Long, Spalte As Long
Dim wkb As Workbook
Dim wksZiel As Worksheet
Dim varDatum, rngID As Range, rngWerte As Range
Set wkb = ActiveWorkbook
Application.StatusBar = "Daten der 4 Tabellen werden in neuer Mappe neu angeordnet"
'Neue Mape anlegen für Vergleichsdaten
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wksZiel = ActiveWorkbook.Worksheets(1)
'Zieltabelle - Spaltentitel eintragen und formatieren
With wksZiel
Zeile = 1
.Cells(Zeile, 1) = "ID"
.Cells(Zeile, 2) = "Datum"
.Cells(Zeile, 3) = "Wert"
.Cells(Zeile, 4) = "Tabelle"
.Range("B:B").NumberFormat = "DD.MM.YYYY"
.Range("A2").Select
ActiveWindow.FreezePanes = True
.Name = "Vergleich " & Format(Date, "YYYY-MM-DD")
End With
Application.ScreenUpdating = False
'Die 4 Tabellenblätter abarbeiten
Zeile = Zeile + 1
For iWs = 1 To 4
With wkb.Worksheets(iWs)
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngID = .Range(.Cells(2, 1), .Cells(Zeile_L, 1))
'Die Spalten ab Soalte 2 abarbeiten
For Spalte = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
varDatum = .Cells(1, Spalte).Value
Set rngWerte = .Range(.Cells(2, Spalte), .Cells(Zeile_L, Spalte))
With wksZiel
rngID.Copy .Cells(Zeile, 1)
.Range(.Cells(Zeile, 2), .Cells(Zeile + rngID.Rows.Count - 1, 2)) = _
varDatum
rngWerte.Copy .Cells(Zeile, 3)
.Range(.Cells(Zeile, 4), .Cells(Zeile + rngID.Rows.Count - 1, 4)) = _
wkb.Worksheets(iWs).Name
End With
Zeile = Zeile + rngID.Rows.Count
Next
End With
Next
With wksZiel
.Columns.AutoFit
'Rahmenlinien ergänzen
With .UsedRange
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
End With
Call MakePivot(wksData:=wksZiel)
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Fertig"
End Sub
Sub MakePivot(wksData As Worksheet)
' Pivot Auswertung erstellen
Dim wksPivot As Worksheet
Dim pvTab As PivotTable
'Tabellenblatt für die auswertung anlegen
wksData.Parent.Worksheets.Add
Set wksPivot = ActiveSheet
'Pivot-tabellenbericht erstellen
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
wksData.Name & "!" & wksData.UsedRange.Address(True, True, xlR1C1)).CreatePivotTable _
TableDestination:=wksPivot.Name & "!R3C1", TableName:="PivotTable1"
wksPivot.Select
wksPivot.Name = "Auswertung"
Set pvTab = wksPivot.PivotTables(1)
'Optioen des Pivotberichtes setzen
With pvTab
.ColumnGrand = False
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = False
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlTabularRow
End With
With pvTab.PivotCache
.RefreshOnFileOpen = False
.MissingItemsLimit = xlMissingItemsNone
End With
pvTab.RepeatAllLabels xlDoNotRepeatLabels
'Spalten /Felder im Bericht plazieren
With pvTab.PivotFields("Tabelle")
.Orientation = xlColumnField
.Position = 1
End With
With pvTab.PivotFields("Datum")
.Orientation = xlRowField
.Position = 1
End With
With pvTab.PivotFields("ID")
.Orientation = xlRowField
.Position = 2
End With
pvTab.AddDataField pvTab.PivotFields("Wert"), "Summe von Wert", xlSum
'keine Teilergebnisse anzeigen
pvTab.PivotFields("ID").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
pvTab.PivotFields("Datum").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
pvTab.PivotFields("Wert").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
pvTab.PivotFields("Tabelle").Subtotals = Array _
(False, False, False, False, False, False, False, False, False, False, False, False)
Range("C5").Select
ActiveWindow.FreezePanes = True
wksPivot.Columns.AutoFit
End Sub