Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1496to1500
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro stoppt ungewollt

Makro stoppt ungewollt
09.06.2016 11:19:15
S
Hallo,
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?

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Beispieldatei?
09.06.2016 15:37:42
Michael
Hi S W,
Du kannst die .bas z.B. zippen, dann läßt sie sich hochladen.
Mir persönlich ist es aber zu mühsam, das Makro ohne Daten zu testen. Warum soll ICH mir die Mühe machen, Testdaten zu erfinden?
Erstelle halt eine Kopie der Datei mit Spieldaten und lösche alles raus, was nichts darin zu suchen hat.
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige