Hallo,
Den Statusbar kannst du mit "DoEvents" aktualisieren. Freigeben kannst du den, wenn du willst. Ich lass ihn ganz gerne so, weil ich mir noch ganz gerne später Laufzeiten, Zähler etc. angucke.
60000 * redim preserve kostet schon ein paar Sekunden. Hab den Code nochmal ein bisschen geändert, sollte jetzt so ziehmlich mit optimaler Geschwindigkeit laufen (Nurnoch 3 * redim preserve, geringere Update-Frequenz für den Statusbar, Variable nW als Double und ohne Val() Funktion, sollte das Gleiche bei rauskommen). Du kannst auch noch Select Case durch eine If-Funktion ersetzen, macht das Ganze noch ein ganz klein bisschen schneller, aber weniger übersichtlich.
Noch was zu Arrays, String Arrays sind bei Textoperationen am schnellsten, numerische bei Rechenoperationen und Variants bei einer Mischung aus beidem. Mit Strings rechnen ist nicht effizient.
Ach ja, müsste Zeile 70 nicht " For y = 1 To efz
Option Explicit
Sub Zusammenfuegen()
'Bildschirmaktualisierung etc. abschalten, um Zeit zu sparen
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 Double, SpeichernUnter As String
Dim I&, offs&, z&, y&, lz&, efz&, lastR&
Dim nWB As Workbook, WB As Workbook, nSh As Worksheet, rng As Range
Dim AV, NeueDaten()
'Pfade+Dateinamen festlegen
Pfad(1) = "\"
Pfad(2) = "\"
DateiName(1) = "Teil1.xls"
DateiName(2) = "Teil2.xls"
'Überschriften in "Spalte" 0 des Arrays
ReDim NeueDaten(4, 0)
NeueDaten(0, 0) = "X"
NeueDaten(1, 0) = "XX"
NeueDaten(2, 0) = "XXX"
NeueDaten(3, 0) = "XXXX"
NeueDaten(4, 0) = "XXXXX"
efz = 1
'Schleife über Dateien
For I = 1 To 2
Set WB = Workbooks.Open(Filename:=Pfad(I) & DateiName(I))
With WB.Sheets(1)
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 = .Range(.Cells(1, 1), .Cells(lz, 13)).Value
End With
ReDim Preserve NeueDaten(4, UBound(NeueDaten, 2) + lz - 2) 'neudimensionieren
lastR = 0
'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) <> "A") And (AV(z, 2) <> "AA") And _
(AV(z, 2) <> "AAA") And (AV(z, 2) <> "AAAA") Then
'Offset bestimmen (nach Spalte 8)
Select Case AV(z, 8)
Case Is = "XX"
offs = 1
Case Is = "XXX"
offs = 2
Case Is = "XXXX"
offs = 3
Case Is = "XXXXX"
offs = 4
End Select
'nW enthält #, "00" eingefügt
nW = Mid(AV(z, 5), 1, 4) & "00" & Mid(AV(z, 5), 5, 8) 'Double als Dateityp statt string und Val(), gleiches Ergebnis?
'prüfen ob # schon vorhanden, dann aufaddieren, sonst neue Spalte
If AV(z, 5) = AV(z - 1, 5) Then
For y = 1 To efz '-1 aufgrund Nutzung Array-Zeile 0, nicht eher start wert + 1?
If NeueDaten(0, y) = nW Then
NeueDaten(offs, y) = NeueDaten(offs, y) + AV(z, 13)
End If
Next
Else
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
'status bar
If z = lastR + 1000 Or z = lz Then
Application.StatusBar = "Zeile: " & z & "/" & lz
DoEvents
lastR = z
End If
Next z
WB.Close (False)
Application.StatusBar = "Datei " & I & "/" & 2 & " erledigt."
DoEvents
Next I
'Transponieren
ReDim Preserve NeueDaten(4, efz - 1) 'array kürzen
transpose NeueDaten
'Speichern in neuer Datei
SpeichernUnter = ThisWorkbook.Path & "\" & _
Format(Date, "YYYYMMDD") & "_" & Format(Time, "HHMMSS") & "_Ergebnis.xls"
Set nWB = Workbooks.Add
With nWB
With .Sheets(1)
'Daten einfügen
.Range(.Cells(1, 1), .Cells(efz, UBound(NeueDaten, 2) + 1)).Value = NeueDaten
'sortieren
.Range(.Cells(1, 1), .Cells(efz, UBound(NeueDaten, 2) + 1)).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
.SaveAs Filename:=SpeichernUnter
.Close (False)
End With
Workbooks("Makros.xls").Sheets(1).Cells(10, 2).Value = "Gespeichert unter: " & SpeichernUnter
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
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
|