Hallo nochmal,
nach weiteren Anpassungen ist noch ein kleines Problem aufgekommen:
Die Statusbarkiste finde ich gut. Wenn aber die Bildschirmaktualisierung ausgeschaltet ist stoppt der Zähler in dem Moment, in dem etwas "über der Statusbar" landet.
Kann man die Bildschirmaktualisierung für die Statusbar aktiv lassen? Wenn die erste XLS geöffnet wird, scheint das neue Fenster halt die Bar zu verdecken, woraufhin dise sich nicht mehr aktualisiert und einfriert...Oder liegt es an etwas anderem? Ich habe die eh schon bestehende Zählvariable z für die Statusbar genutzt, anstelle der R.
Das da im Hintergrund die beiden Teildateien geöffnet werden, möchte ich aber auch nicht anzeigen :-)
Es empfiehlt sich (wie ich las) die Statusleiste am Ende wieder freizugeben.
Application.StatusBar = False
Hier der Code:
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 String, SpeichernUnter As String
Dim i&, offs&, z&, y&, lz&, efz&, lastR&
Dim nWB 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
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 = Range(Cells(1, 1), Cells(lz, 13)).Value
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 = Val(Mid(AV(z, 5), 1, 4) & "00" & Mid(AV(z, 5), 5, 8))
'prüfen ob # 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 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
'status bar
If z = lastR + 50 Or z = lz Then
Application.StatusBar = "Zeile: " & z & "/" & lz
lastR = z
End If
Next z
Workbooks(DateiName(i)).Close (False)
Application.StatusBar = "Datei " & i & "/" & 2 & " erledigt."
Next i
'Transponieren
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
|