|
Hey Till,
ich hätte wohl besser den neuen Code posten sollen. Ich habe deinen Ansatz etwas verändert und damit weitergebaut. Du hast natürlich auf Basis deines Ansatzes weitergearbeitet.
Ich habe nun etwas aus deinem zuletzt geposteten Code zusammengebastelt, was in 57 Sekunden durchläuft :-) Super Ergebnis. Und gleichzeitig war ich mal gezwungen mir Kenntnisse zu Arrays anzueignen (ubound, lbound, redim preserve...). Danke dafür
Transpose benötigt keinerlei Zeit. Da steht dann 0 oder 1 in der Benchmarkvariable. "Neudimensionierungen" bzw. Zeilen im Endergebnis gibt es 63927.
Mit der Statusbar beschäftige ich mich jetzt gleich noch. Und du hast immer ein & an Variablen hinten dran. Werde ich mich auch mal mit beschäftigen.
Danke für deine Hilfe
Option Explicit
Sub Zusammenfuegen()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Variablen
Dim DateiName(1 To 2) As String, Pfad(1 To 2) As String, nW As String
Dim i As Long, offs As Long, z As Long, y As Long
Dim nWB As Workbook
Dim lz As Double, efz As Double
Dim AV, rng As Range, nSh As Worksheet
Dim NeueDaten()
Dim t
Dim NewPath As String
'Pfade+Dateinamen festlegen
Pfad(1) = "der Pfad\"
Pfad(2) = "der Pfad\"
DateiName(1) = "Teil1.xls"
DateiName(2) = "Teil2.xls"
'Überschriften in "Spalte" 0 des Arrays
ReDim NeueDaten(4, 0)
NeueDaten(0, 0) = "Ü1" 'Hier steht die Kundennummer drin --> Spalte 0 im Array
NeueDaten(1, 0) = "Ü2"
NeueDaten(2, 0) = "Ü3"
NeueDaten(3, 0) = "Ü4"
NeueDaten(4, 0) = "Ü5"
efz = 1 'sonst führt "ReDim Preserve NeueDaten(4, efz)" zu Indexfehler, da efz noch LEER
'Schleife über Dateien
For i = 1 To 2
Workbooks.Open Filename:=Pfad(i) & DateiName(i)
lz = Cells(Rows.Count, 5).End(xlUp).Row
Set rng = Range(Cells(1, 1), Cells(lz, 13)) 'hier wurden sehr
'viele Daten ausgelesen, aber Spalte 13 wird benötigt!
'Teile auslesen statt gesamtem Bereich? Spalten 2,5,8,13 relevant
'und später benötigt
AV = rng.Value
'Schleife über Zeilen der Datei i
For z = 2 To lz 'Start bei Zeile 2 wg. Überschriften
'Ausschlusskriterien prüfen (Spalte 2)
If (AV(z, 2) <> "A1") And (AV(z, 2) <> "A2") And _
(AV(z, 2) <> "A3") And (AV(z, 2) <> "A4") Then
'Offset bestimmen (nach Spalte 8)
Select Case AV(z, 8)
Case Is = "Ü2"
offs = 1
Case Is = "Ü3"
offs = 2
Case Is = "Ü4"
offs = 3
Case Is = "Ü5"
offs = 4
End Select
'nW enthält Kundennummer, "00" eingefügt
nW = Val(Mid(AV(z, 5), 1, 4) & "00" & Mid(AV(z, 5), 5, 8))
'prüfen ob Kundendnummer schon vorhanden, dann aufaddieren, sonst neue Spalte
If AV(z, 5) = AV(z - 1, 5) Then
For y = 0 To efz - 1 '-1 aufgrund Nutzung Array-Zeile 0
If NeueDaten(0, y) = nW Then
NeueDaten(offs, y) = NeueDaten(offs, y) + AV(z, 13)
End If
Next
Else
ReDim Preserve NeueDaten(4, efz) 'eine Spalte ans Array anfügen
NeueDaten(0, efz) = nW 'Zeile 0 = Überschrift
NeueDaten(offs, efz) = AV(z, 13) 'nicht alter Wert + neuer Wert, da alter nicht vorhanden
'und Indexfehler bei Ansteuerung des Arrays
efz = efz + 1
End If
End If
Next z
Workbooks(DateiName(i)).Close (False)
Next i
'Transponieren
t = Time
transpose NeueDaten
t = t - Time
Debug.Print t
'Speichern
NewPath = ThisWorkbook.Path & "\" & _
Format(Date, "YYYYMMDD") & "_" & Format(Time, "HHMMSS") & "_Ergebnis.xls"
Set nWB = Workbooks.Add
With nWB
With .Sheets(1)
.Range(.Cells(1, 1), .Cells(efz + 1, UBound(NeueDaten, 2) + 1)).Value = NeueDaten
End With
.SaveAs Filename:=NewPath
.Close (False)
End With
Workbooks("Makros.xls").Sheets(1).Cells(10, 2).Value = "Gespeichert unter: " & NewPath
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Debug.Print "Anzahl der Neudimensionierungen: " & efz
End Sub
Private Function transpose(Arr)
Dim R&, C&, S1&, S2&, E1&, E2&
Dim nArr
nArr = Arr
S1 = LBound(Arr)
S2 = LBound(Arr, 2)
E1 = UBound(Arr)
E2 = UBound(Arr, 2)
ReDim Arr(S2 To E2, S1 To E1)
For R = S1 To E1
For C = S2 To E2
Arr(C, R) = nArr(R, C)
Next C
Next R
End Function
|