AW: Viele Daten in eine Tabelle zusammenführen
13.11.2017 18:21:17
fcs
Hallo Julian,
ich hatte mich schon mit deinem Problem beschäfftigt bevor du die Info gegeben hast, dass du eine Gesamtdatei fürd Jahr bekommen kannst.
Deshalb hier noch meine 2 Varianten, um die Tagesdateien in eine Gesamtdatei zu überführen.
Gruß
Franz
'Variante A ist optimal für Pivot-Auswertung, erzeugt aber fast eine Million Datenzeilen
'Laufzeit des Makros dürfte bei 365 Dateien sehr groß sein,
Sub Auswertung_vorbereiten_Var_A()
Dim wkbQ As Workbook
Dim wksQ As Worksheet
Dim wksW As Worksheet
Dim wksZ As Worksheet
Dim Zei_Z As Long
Dim Zei_Q As Long, Spa_Q As Long
Dim varJahr As String
Dim varOrdner
Dim arrMonate
Dim strDatei
Dim intTag As Integer, intMonat As Integer
Dim rngDatum As Range
Dim strAbnahme As String, varEnergie, varmax
Dim CalcStatus As Long
'Array mit dem Monatsnamen erzeugen
ReDim arrMonate(1 To 12)
For intMonat = 1 To 12
arrMonate(intMonat) = Format(DateSerial(2000, intMonat, 1), "MMMM")
Next
varJahr = InputBox("Jahr (letzte 2 Ziffern) für das die Auswertung " _
& "durchgeführt werden soll:", "Auswertung Wirkenergie Bezug", 16)
If varJahr = "" Then GoTo Beenden
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte übergeordneten Ordner mit den Monats-Ordnern auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
With Application
.ScreenUpdating = False
CalcStatus = .Calculation
.Calculation = xlCalculationManual
End With
For intMonat = 1 To 12
If Dir(varOrdner & "\" & arrMonate(intMonat), vbDirectory) "" Then
For intTag = 1 To 31
strDatei = Dir(varOrdner & "\" & arrMonate(intMonat) & "\" _
& Format(Val(varJahr), "00") _
& Format(intMonat, "00") & Format(intTag, "00") & "*.xlsx", vbNormal)
If strDatei "" Then
strDatei = varOrdner & "\" & arrMonate(intMonat) & "\" & strDatei
Set wkbQ = Application.Workbooks.Open(strDatei, ReadOnly:=True)
Set wksQ = wkbQ.Worksheets(1)
If wksZ Is Nothing Then
'Ergebnisblatt anlegen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wksZ = ActiveSheet
Zei_Z = 1
With wksZ
.Name = "Wirkenergie Bezug"
.Cells(Zei_Z, 1) = "Abnahmestelle"
.Cells(Zei_Z, 2) = "Datum_Zeit"
.Cells(Zei_Z, 3) = "kW"
.Cells(Zei_Z, 4) = "Energie"
.Cells(Zei_Z, 5) = "Max"
.Columns(1).AutoFit
.Columns(2).ColumnWidth = 15
Range("A2").Select
ActiveWindow.FreezePanes = True
Zei_Z = Zei_Z + 1
End With
End If
With wksQ
'Datums-Text in Spalte A in Datumswerte umwandeln
For Zei_Q = 13 To .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(Zei_Q, 1)
.Value = CDate(.Text)
End With
Next
Zei_Q = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngDatum = .Range(.Cells(13, 1), .Cells(Zei_Q, 1))
'Abnahmestellen abarbeiten
For Spa_Q = 2 To .Cells(7, Columns.Count).End(xlToLeft).Column
strAbnahme = .Cells(7, Spa_Q).Text
varEnergie = .Cells(9, Spa_Q).Value
varmax = .Cells(10, Spa_Q).Value
With wksZ
.Range(.Cells(Zei_Z, 1), _
.Cells(Zei_Z + rngDatum.Rows.Count - 1, 1)).Value = _
strAbnahme
.Cells(Zei_Z, 4).Value = varEnergie
.Cells(Zei_Z, 5).Value = varmax
End With
rngDatum.Copy
wksZ.Cells(Zei_Z, 2).PasteSpecial Paste:=xlPasteValues
rngDatum.Offset(0, Spa_Q - 1).Copy
wksZ.Cells(Zei_Z, 3).PasteSpecial Paste:=xlPasteValues
Zei_Z = Zei_Z + rngDatum.Rows.Count
Next
Set rngDatum = Nothing
End With
Application.CutCopyMode = False
wkbQ.Close savechanges:=False
Set wkbQ = Nothing
Set wksQ = Nothing
End If
Next
End If
Next
With wksZ
.Columns(2).NumberFormat = "DD.MM.YY hh:mm"
.Columns(3).NumberFormat = "#,##0.00"
.Columns(4).NumberFormat = "#,##0.0"
.Columns(5).NumberFormat = "#,##0.00"
End With
With Application
.ScreenUpdating = True
.Calculation = CalcStatus
End With
MsgBox "Fertig"
Beenden:
End Sub
'Variante B entspricht in etwa deiner Vorgabe für die Ergebnistabelle
Sub Auswertung_vorbereiten_Var_B()
Dim wkbQ As Workbook
Dim wksQ As Worksheet
Dim wksW As Worksheet
Dim wksZ As Worksheet
Dim Zei_Z As Long
Dim Zei_Q As Long
Dim varJahr As String
Dim varOrdner
Dim arrMonate
Dim strDatei
Dim intTag As Integer, intMonat As Integer
Dim rngDatum As Range
Dim CalcStatus As Long
'Array mit dem Monatsnamen erzeugen
ReDim arrMonate(1 To 12)
For intMonat = 1 To 12
arrMonate(intMonat) = Format(DateSerial(2000, intMonat, 1), "MMMM")
Next
varJahr = InputBox("Jahr (letzte 2 Ziffern) für das die Auswertung " _
& "durchgeführt werden soll:", "Auswertung Wirkenergie Bezug", 16)
If varJahr = "" Then GoTo Beenden
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte übergeordneten Ordner mit den Monats-Ordnern auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
With Application
.ScreenUpdating = False
CalcStatus = .Calculation
.Calculation = xlCalculationManual
End With
For intMonat = 1 To 12
If Dir(varOrdner & "\" & arrMonate(intMonat), vbDirectory) "" Then
For intTag = 1 To 31
strDatei = Dir(varOrdner & "\" & arrMonate(intMonat) & "\" _
& Format(Val(varJahr), "00") _
& Format(intMonat, "00") & Format(intTag, "00") & "*.xlsx", vbNormal)
If strDatei "" Then
strDatei = varOrdner & "\" & arrMonate(intMonat) & "\" & strDatei
Set wkbQ = Application.Workbooks.Open(strDatei, ReadOnly:=True)
Set wksQ = wkbQ.Worksheets(1)
If wksZ Is Nothing Then
'Ergebnisblatt anlegen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wksZ = ActiveSheet
Zei_Z = 1
With wksZ
.Name = "Wirkenergie Bezug"
wksQ.Range(wksQ.Rows(2), wksQ.Rows(7)).Copy .Rows(1)
wksQ.Rows(7).Copy
wksZ.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Range("A6").Copy .Range("B2")
.Range("A6") = "Datum_Zeit"
Range("A7").Select
ActiveWindow.FreezePanes = True
Zei_Z = Zei_Z + 6
End With
End If
With wksQ
'Datums-Text in Spalte A in Datumswerte umwandeln
For Zei_Q = 13 To .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(Zei_Q, 1)
.Value = CDate(.Text)
End With
Next
Zei_Q = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngDatum = .Range(.Cells(13, 1), .Cells(Zei_Q, 1))
rngDatum.EntireRow.Copy wksZ.Cells(Zei_Z, 1)
Zei_Z = Zei_Z + rngDatum.Rows.Count
Set rngDatum = Nothing
End With
Application.CutCopyMode = False
wkbQ.Close savechanges:=False
Set wkbQ = Nothing
Set wksQ = Nothing
End If
Next
End If
Next
With wksZ
With .Columns(1)
.NumberFormat = "DD.MM.YY hh:mm"
.AutoFit
End With
End With
With Application
.ScreenUpdating = True
.Calculation = CalcStatus
End With
MsgBox "Fertig"
Beenden:
End Sub