Option Explicit
Sub Zusammenfuegen()
Dim A As Object
Set A = Application
With A
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim DateiName(1 To 2) As String
Dim Pfad(1 To 2) As String
Dim I&, J&, lz&, efz&, z&, Offs&, R&, lastR& 'lz=letzte Zeile; efz=erste freie Zeile
Dim nWB As Workbook, WB As Workbook
Dim nW As String
Dim AV, rng As Range, nSh As Worksheet
Dim NeueDaten, V, Au1$, Au2$, Au3$, Au4$, NewPath$
'set
Pfad(1) = Workbooks("Makros.xlsm").Path & "\"
Pfad(2) = Workbooks("Makros.xlsm").Path & "\"
DateiName(1) = "Teil1.xls"
DateiName(2) = "Teil2.xls"
Au1 = "Ausschluss1"
Au2 = "Ausschluss2"
Au3 = "Ausschluss3"
Au4 = "Ausschluss4"
Set nWB = Workbooks.Add
Set nSh = nWB.Sheets(1)
With nSh
.Cells(1, 1).Value = "Ü1"
.Cells(1, 2).Value = "Ü2"
.Cells(1, 3).Value = "Ü3"
.Cells(1, 4).Value = "Ü4"
.Cells(1, 5).Value = "Ü5"
End With
ReDim neuedatem(4, 0)
'calc
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, 5))
End With
AV = rng.Value
For z = 1 To lz
V = AV(z + 1, 2)
If (V <> Au1) _
And (V <> Au2) _
And (V <> Au3) _
And (V <> Au4) Then
Select Case AV(z + 1, 8)
Case Is = "Ü2"
Offs = 1
Case Is = "Ü3"
Offs = 2
Case Is = "Ü4"
Offs = 3
Case Is = "Ü5"
Offs = 4
End Select
nW = Left(AV(z + 1, 5), 4) & "00" & Mid(AV(z + 1, 5), 5, 8)
If AV(z + 1, 5) = AV(z, 5) Then
For I = 0 To efz
If NeueDaten(0, I) = nW Then
NeueDaten(Offs, I) = NeueDaten(1, I) + AV(z + 1, 13)
End If
Next
Else
ReDim Preserve NeueDaten(efz)
NeueDaten(1, efz) = nW
NeueDaten(Offs + 1, efz) = NeueDaten(Offs + 1, efz) + AV(z + 1, 13)
efz = efz + 1
End If
End If
'status bar
If R = lastR + 100 Or R = lz Then
A.StatusBar = "Zeile: " & R & "/" & lz
lastR = R
End If
Next z
lastR = 0
WB.Close (False)
A.StatusBar = "Files: " & I & "/" & 2
Next I
'transpose
t = Now()
transpose NeueDaten
t = Now() - t
MsgBox "Fürs transponieren benötigte Zeit: " & Format(t, "ss")
'save
NewPath = Workbooks("Makros.xlsm").Path & "\" & Format(Date, "YYYYMMDD") & "_Ergebnis.xls"
With nWB
With .Sheets(1)
.Range(.Cells(2, 1), .Cells(efz, UBound(NeueDaten, 2))).Value = NeueDaten
End With
.SaveAs Filename:=NewPath
.Close (False)
End With
With A
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
MsgBox "Datei unter " & NewPath & " gespeichert."
MsgBox "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
Next
End Function
Falls du den Code so zum laufen bringst, wie viel Neudimensionierungen werden ausgegeben, wie lange braucht die Transponieren-Funktion?
|