Makro stoppt ungewollt
09.06.2016 11:19:15
S
mein Makro stoppt für mich ohne ersichtlichen Grund. Kann leider nicht die gesamte Excel Mappe hochladen, da diese interne Informationen beinhaltet.
Makro:
Sub FactorsToText()
' FactorsToText Makro
' Tastenkombination: Strg+Umschalt+T
On Error GoTo Fehlerbehandlung
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Debug.Print "YES"
Dim Pipe1 As Worksheet, Pipe2 As Worksheet, Trans1 As Worksheet, Trans2 As Worksheet, _
Output As Worksheet
Set Pipe1 = Worksheets(1)
Set Pipe2 = Worksheets(2)
Set Trans1 = Worksheets(3)
Set Output = Worksheets(4)
If LastRow(Output) > 3 Then
Output.Range("A3:L" & LastRow(Output)).ClearContents
Else
Output.Range("A3:L5").ClearContents
End If
Dim FaktorSpalten() As Integer, PolicyNoSpalte As Integer, alternatFaktorSpalten() As _
Integer
ReDim FaktorSpalten(4), alternatFaktorSpalten(4)
FaktorSpalten(0) = 6
FaktorSpalten(1) = 10
FaktorSpalten(2) = 11
FaktorSpalten(3) = 20
PolicyNoSpalte = 6
alternatFaktorSpalten(0) = 5
alternatFaktorSpalten(1) = 10
alternatFaktorSpalten(2) = 11
alternatFaktorSpalten(3) = 20
Dim ZeileGefundenPipe1() As Boolean, ZeileGefundenPipe2() As Boolean
ReDim ZeileGefundenPipe1(LastRow(Pipe1)), ZeileGefundenPipe2(LastRow(Pipe2))
Debug.Print "1"
Dim BlattVerkürzungPipe1() As String, BlattVerkürzungPipe2() As String
BlattVerkürzungPipe1 = ToText(Pipe1, FaktorSpalten, PolicyNoSpalte, alternatFaktorSpalten, _
_
_
10)
Debug.Print "2"
BlattVerkürzungPipe2 = ToText(Pipe2, FaktorSpalten, PolicyNoSpalte, alternatFaktorSpalten, _
_
_
10)
Debug.Print "3"
Dim Zähler As Long, GrossPipe As Integer
Zähler = 3
GrossPipe = 27
For i = 10 To LastRow(Pipe1)
ZeileGefundenPipe1(i) = False
For k = 3 To LastRow(Output)
If BlattVerkürzungPipe1(i) = Output.Cells(k, 1) Then
Output.Cells(k, 7) = Output.Cells(k, 7) + Pipe1.Cells(i, GrossPipe)
ZeileGefundenPipe1(i) = True
Output.Cells(k, 10) = Output.Cells(k, 10) + 1
End If
Next k
If ZeileGefundenPipe1(i) = False Then
For j = 10 To LastRow(Pipe2)
If BlattVerkürzungPipe1(i) = BlattVerkürzungPipe2(j) Then
ZeileGefundenPipe1(i) = True
ZeileGefundenPipe2(j) = True
Output.Cells(Zähler, 1) = BlattVerkürzungPipe1(i)
Output.Cells(Zähler, 2) = RTrim(Pipe1.Cells(i, alternatFaktorSpalten(0)))
For k = 0 To UBound(FaktorSpalten) - 1
Output.Cells(Zähler, 3 + k) = Pipe1.Cells(i, FaktorSpalten(k))
Next k
Output.Cells(Zähler, 7) = Pipe1.Cells(i, GrossPipe)
Output.Cells(Zähler, 8) = Output.Cells(Zähler, 8) + Pipe2.Cells(i, _
GrossPipe)
'Output.Cells(Zähler, 8) = Pipe2.Cells(i, GrossPipe)
Output.Cells(Zähler, 10) = Output.Cells(Zähler, 10) + 1
End If
Next j
If ZeileGefundenPipe1(i) = False Then
ZeileGefundenPipe1(i) = True
Output.Cells(Zähler, 1) = BlattVerkürzungPipe1(i)
Output.Cells(Zähler, 2) = RTrim(Pipe1.Cells(i, alternatFaktorSpalten(0)))
For k = 0 To UBound(FaktorSpalten) - 1
Output.Cells(Zähler, 3 + k) = Pipe1.Cells(i, FaktorSpalten(k))
Next k
Output.Cells(Zähler, 7) = Pipe1.Cells(i, GrossPipe)
Output.Cells(Zähler, 8) = 0
Output.Cells(Zähler, 10) = Output.Cells(Zähler, 10) + 1
End If
Zähler = Zähler + 1
End If
Next i
For i = 10 To LastRow(Pipe2)
For k = 3 To LastRow(Output)
If BlattVerkürzungPipe2(i) = Output.Cells(k, 1) And ZeileGefundenPipe2(i) = False _
_
_
Then
Output.Cells(k, 8) = Output.Cells(k, 8) + Pipe2.Cells(i, GrossPipe)
ZeileGefundenPipe2(i) = True
Output.Cells(k, 10) = Output.Cells(k, 10) + 1
End If
Next k
If ZeileGefundenPipe2(i) = False Then
ZeileGefundenPipe2(i) = True
Output.Cells(Zähler, 1) = BlattVerkürzungPipe2(i)
Output.Cells(Zähler, 2) = RTrim(Pipe2.Cells(i, alternatFaktorSpalten(0)))
For k = 0 To UBound(FaktorSpalten) - 1
Output.Cells(Zähler, 3 + k) = Pipe2.Cells(i, FaktorSpalten(k))
Next k
Output.Cells(Zähler, 8) = Pipe2.Cells(i, GrossPipe)
Output.Cells(Zähler, 10) = Output.Cells(Zähler, 10) + 1
Zähler = Zähler + 1
End If
Next i
ReDim FaktorSpalten(4), alternatFaktorSpalten(4)
FaktorSpalten(0) = 1
FaktorSpalten(1) = 17
FaktorSpalten(2) = 18
FaktorSpalten(3) = 2
PolicyNoSpalte = 1
alternatFaktorSpalten(0) = 9
alternatFaktorSpalten(1) = 17
alternatFaktorSpalten(2) = 18
alternatFaktorSpalten(3) = 2
Dim ZeileGefundenTrans1() As Boolean
ReDim ZeileGefundenTrans1(LastRow(Trans1))
Dim BlattVerkürzungTrans1() As String
BlattVerkürzungTrans1 = ToText(Trans1, FaktorSpalten, PolicyNoSpalte, alternatFaktorSpalten, _
_
_
3)
Dim altBlattVerkürzungTrans1() As String
altBlattVerkürzungTrans1 = ToText(Trans1, FaktorSpalten, 2, alternatFaktorSpalten, 3)
Dim GrossTrans As Integer
GrossTrans = 23
For i = 3 To LastRow(Trans1)
ZeileGefundenTrans1(i) = False
For k = 3 To LastRow(Output)
If Output.Cells(k, 1) "" Then
If (Asc(Left(Output.Cells(k, 1), 1)) _
_
_
47) Then
If BlattVerkürzungTrans1(i) = Output.Cells(k, 1) Then
Output.Cells(k, 9) = Output.Cells(k, 9) + Trans1.Cells(i, GrossTrans)
ZeileGefundenTrans1(i) = True
Output.Cells(k, 10) = Output.Cells(k, 10) + 1
End If
Else
If altBlattVerkürzungTrans1(i) = Output.Cells(k, 1) Then
Output.Cells(k, 9) = Output.Cells(k, 9) + Trans1.Cells(i, GrossTrans)
ZeileGefundenTrans1(i) = True
Output.Cells(k, 10) = Output.Cells(k, 10) + 1
End If
End If
End If
Next k
If ZeileGefundenTrans1(i) = False Then
ZeileGefundenTrans1(i) = True
Output.Cells(Zähler, 1) = BlattVerkürzungTrans1(i)
Output.Cells(Zähler, 2) = RTrim(Trans1.Cells(i, alternatFaktorSpalten(0)))
For k = 0 To UBound(FaktorSpalten) - 1
Output.Cells(Zähler, 3 + k) = Trans1.Cells(i, FaktorSpalten(k))
Next k
Output.Cells(Zähler, 9) = Trans1.Cells(i, GrossTrans)
Output.Cells(Zähler, 10) = Output.Cells(Zähler, 10) + 1
Zähler = Zähler + 1
End If
Next i
Output.Range("K3:K" & Zähler).Formula = "=G3-H3"
Output.Range("L3:L" & Zähler).Formula = "=K3-I3"
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Fehlerbehandlung:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Public Function ToText(wks As Worksheet, FaktorSpalten() As Integer, PolicyNoSpalte As Integer, _
_
_
alternatFaktorSpalten() As Integer, Zeile As Integer) As String()
Dim text1() As String
ReDim text1(LastRow(wks))
For i = Zeile To LastRow(wks)
If Asc(wks.Cells(i, PolicyNoSpalte)) > 57 And Asc(wks.Cells(i, PolicyNoSpalte) lngFirst + 1
lngTmp = (lngFirst + lngLast) \ 2
If .CountA(wks.Rows(lngTmp).Resize(lngLast - lngTmp)) Then _
lngFirst = lngTmp Else lngLast = lngTmp
Loop
If .CountA(wks.Rows(lngLast)) Then LastRow = lngLast Else LastRow = lngFirst
End With
End Function
Direktbereich Ausgabe:
1
2
Fehlerbeschreibung:
Normalerweise läuft das Makro für ein paar Minuten und schreibt dann alle seine Ergebnisse in ein Output-Sheet. Doch wenn ich es jetzt laufen lasse läuft es gefühlt keine Sekunde.
Bei Wechsel zu vorheriger Version des Makros passiert der Fehler obwohl dies zuvor nicht der Fall war.
Interessant ist auch das kein Error auftritt, da "Fehlerbehandlung" nicht aufgerufen wird, also der Berechnungsmodus in manuell bleibt.
Danke für jede Hilfe
Grüße
PS: Erster Forumseintrag
PSS: Warum kann ich keine .bas Dateien hochladen?