Makro hängt sich auf. Wo ist der Fehler?
17.03.2006 17:00:07
Matthias
ich habe untenstehenden Code, der sich Immer innerhalb der Funtktion "intSzenario_Spalte" aufzuhängen scheint. Allerdings kann ich leider nicht den Fehler finden woran es liegt, dass das Makro nicht durchläuft. Hat jm. von Euch eine Idee?
Grüße Matthias
Option Explicit
Sub EmpfängerAuswählen()
ReportGenerieren 0, True
End Sub
Sub ReportGenerieren(intEmpfänger As Integer, bolAuswahlZeigen As Boolean)
'************************
'* Variablendeklaration *
'************************
Dim intAuswahl As Integer 'Enthält Auswahl des Empfängers aus DialogSheet
Dim intSpalteLayout As Integer 'für individuellen Bericht gewünschte Spalte
Dim intSpalteVAR As Integer 'aus "VAR" zu übertragende Spalte
Dim intSpalteVARCOL As Integer 'in "VARCOL" übertragene Spalte
Dim i As Integer 'Zählvariable
Dim shVAR As Worksheet 'variables Rechenblatt
Dim shVARCOL As Worksheet 'generierter Berichtsausschnitt
Dim shLAYOUT As Worksheet 'enthält die Spaltendefinitionen für "VARCOL"
Dim strFormel As String 'enthält Formel aus Layout
Dim strSzenario1 As String
Dim strSzenario2 As String
Dim intNenner As Integer
Dim intZaehler As Integer
Set shVAR = Worksheets("VAR") 'weist Variable "shVAR" die Tabelle "VAR" zu
Set shVARCOL = Worksheets("VARCOL") 'weist Variable "shVARCOL" die Tabelle "VARCOL" zu
Set shLAYOUT = Worksheets("LAYOUT") 'weist Variable "shLAYOUT" die Tabelle "LAYOUT" zu
'******************************************************************************************
'* ruft DialogSheet "D_BerichtWaehlen" zur Auswahl des gewünschten Berichtsempfängers auf *
'* und übergibt die Auswahl an die Variable "intEmpfänger" *
'******************************************************************************************
If bolAuswahlZeigen Then
DialogSheets("D_BerichtWaehlen").Show
intEmpfänger = DialogSheets("D_BerichtWaehlen").ListBoxes("Liste").ListIndex
End If
Application.ScreenUpdating = False 'deaktiviert Bildschirmdarstellung
Application.Calculation = xlManual 'deaktiviert Tabellenberechnung
shVARCOL.Range("D7:IV79").Delete 'löscht alte Berichtsbestandteile in "VARCOL"
'******************************************************************************************
'* Sucht die in "LAYOUT" definierten Spalten in "VAR" und stellt auf "VARCOL" Bezüge zu *
'* den gefundenen Spalten her, damit sich bei einem Quellenwechsel auch der Bericht auf *
'* "VARCOL" automatisch anpasst *
'******************************************************************************************
If intEmpfänger Then
intSpalteLayout = 2
intSpalteVARCOL = 4
Do
intSpalteVAR = 4
Do
strFormel = shLAYOUT.Cells(intEmpfänger + 1, intSpalteLayout)
If Left$(strFormel, 6) = "Growth" Then
strSzenario1 = Mid$(strFormel, 8, InStr(8, strFormel, "/", vbTextCompare) - 1 - 7)
strSzenario2 = Right$(strFormel, Len(strFormel) - InStr(8, strFormel, "/", vbTextCompare))
intNenner = intSzenario_Spalte(strSzenario1)
intZaehler = intSzenario_Spalte(strSzenario2)
Sheets("VARCOL").Cells(10, intSpalteVARCOL).FormulaR1C1 = "=VAR!R10C" & intZaehler & "/VAR!R10C" & intNenner & " -1"
Else
'***************************************************
'* sucht die "LAYOUT" definierten Spalten in "VAR" *
'***************************************************
If shVAR.Cells(7, intSpalteVAR) = strFormel Then
MsgBox "intSpalteVAR: " & intSpalteVAR & " strFormel: " & strFormel
'*******************************************************************
'* -durchläuft "VAR" so lange, bis in "LAYOUT" leere Zelle *
'* -wird eine Spalte gefunden, wird in "VARCOL" zur entsprechenden *
'* Spalte in "VAR" ein Bezug hergestellt *
'*******************************************************************
Sheets("VARCOL").Activate 'erforderlich für Verknüpfungen
For i = 7 To 78 'durchläuft VAR-Zeilen 7 - 78
shVAR.Cells(i, intSpalteVAR).Copy 'kopiert die Spalten aus VAR
With shVARCOL 'fügt Spalten in "VARCOL" ein
.Cells(i, intSpalteVARCOL).Select 'notwendig für .Paste Link:=True
.Paste 'fügt zunächst alles ein
.Paste Link:=True 'ersetzt Einträge durch Bezüge
End With
Next i
intSpalteVARCOL = intSpalteVARCOL + 1 'springt eine Zelle nach rechts
Exit Do
End If
intSpalteVAR = intSpalteVAR + 1 'springt eine Zelle nach rechts
'*************************************************************************************
'* -durchsucht die komplette Zeile in "VAR" nach den in "LAYOUT" definierten Spalten *
'* -wird diese nicht gefunden, erfolgt ein Schleifenabbruch und Ausgabe einer *
'* Fehlermeldung mit Sprung zu der in "LAYOUT" falsch definierten Spalte *
'*************************************************************************************
If intSpalteVAR > 256 Then 'Ende von "VAR" wurde erreicht
Application.ScreenUpdating = True
Sheets("Layout").Activate
Cells(intEmpfänger + 1, intSpalteLayout).Select
MsgBox shLAYOUT _
.Cells(intEmpfänger + 1, intSpalteLayout) & " Spalte existiert in VAR nicht"
Exit Sub
End If
End If
Loop
intSpalteLayout = intSpalteLayout + 1 'springt eine Zelle nach rechts
Loop Until _
shLAYOUT.Cells(intEmpfänger + 1, intSpalteLayout) = "" 'durchläuft LAYOUT-Zeile
End If 'bis leere Zelle
shVARCOL.Select
Columns("D:IV").ColumnWidth = 13.56 'passt die Spaltenbreite an
Rows("7:7").RowHeight = 132 'passt die Zeilenhöhe an
Application.Calculation = xlAutomatic 'aktiviert Tabellenberechnung
End Sub
Function intSzenario_Spalte(strSzenario As String) As Integer
Sheets("VAR").Select
On Error GoTo fehler
Cells.Find(What:=strSzenario, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
intSzenario_Spalte = ActiveCell.Column
On Error GoTo 0
Exit Function
fehler:
MsgBox strSzenario & ": Szenario existiert nicht!"
End
End Function