AW: Hat da keiner Ahnung?
24.02.2005 22:19:02
Emu
Moin!
Schönen Dank erstmal, dass Du mein Gejammer erhört hast. Habe leider grad kein schickes Tool für den Code, deshalb kopier ich den einfach hier rein. Die Stelle an ders hängt markier ich fett und kursiv. Was ich halt nicht kapiere ist, warum schafft er das über 2000x mit teilweise identischen Werten, und dann auf einmal nicht mehr?
Also, schau hier (aber nicht lachen...):
Sub Soziogramme_Einfuegen()
' Warnungen abschalten
Application.DisplayAlerts = False
' Variablen deklarieren
Dim zeilen, spalten, anfangzahl, endezahl, ganummer, gwnummer, letzteanfangzahl, asciispalte, _
spaltenschleifenanfang, zeilenschleifenanfang, zeilenschleifenanfangi, spaltenschleifenanfangi As Long
Dim bereich, bildnummer, anfang, ende, spalte As String
Dim ga, gw As Double
' Tabellenmaße abfragen
zeilen = ActiveSheet.UsedRange.Rows.Count
spalten = ActiveSheet.UsedRange.Columns.Count
' Startpunkt abfragen
spaltenschleifenanfang = 51
zeilenschleifenanfang = 2
' Anfangspunk festlegen
anfangzahl = zeilenschleifenanfang
asciispalte = spaltenschleifenanfang + 64
' Endpunkt festlegen
letzteanfangzahl = zeilen - 1
' Schleifen-Anfänge festlegen
zeilenschleifenanfangi = zeilenschleifenanfang
spaltenschleifenanfangi = spaltenschleifenanfang
' Spalten-Schleife Beginn
For h = spaltenschleifenanfangi To spalten
' Spalte festlegen
If asciispalte <= 90 Then
spalte = Chr(asciispalte)
Else
spalte = Chr(Int((asciispalte - 64) / 26) + 64) + Chr((asciispalte - (Int((asciispalte - 64) / 26) * 26)))
End If
' Zeilen-Schleife Beginn
For i = zeilenschleifenanfangi To letzteanfangzahl Step 2
' Range festlegen
endezahl = anfangzahl + 1
anfang = spalte + Format(anfangzahl)
ende = spalte + Format(endezahl)
bereich = anfang + ":" + ende
' GA- und GW-Werte abfragen
ga = Range(anfang).Value
gw = Range(ende).Value
' Bildnummer festlegen
If ga = 0 Then
ganummer = 0
ElseIf ga > 0 And ga <= 6.25 Then
ganummer = 1
ElseIf ga > 6.25 And ga <= 12.5 Then
ganummer = 2
ElseIf ga > 12.5 And ga <= 25 Then
ganummer = 3
ElseIf ga > 25 And ga <= 50 Then
ganummer = 4
ElseIf ga > 50 And ga <= 100 Then
ganummer = 5
End If
If gw = 0 Then
gwnummer = 0
ElseIf gw > 0 And gw <= 6.25 Then
gwnummer = 1
ElseIf gw > 6.25 And gw <= 12.5 Then
gwnummer = 2
ElseIf gw > 12.5 And gw <= 25 Then
gwnummer = 3
ElseIf gw > 25 And gw <= 50 Then
gwnummer = 4
ElseIf gw > 50 And gw <= 100 Then
gwnummer = 5
End If
If ganummer = 0 Or gwnummer = 0 Then
bildnummer = "0"
Else
bildnummer = Format(gwnummer) + Format(ganummer)
End If
' Soziogramm einfügen!
Range(bereich).Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
Selection.ClearContents
ActiveSheet.Pictures.Insert("D:\Diplom\Preisinger\Preisinger_" + bildnummer + ".bmp").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 27.75
Selection.ShapeRange.Width = 27.75
Selection.ShapeRange.IncrementLeft 3
Selection.ShapeRange.IncrementTop 1.5
Selection.ShapeRange.PictureFormat.IncrementContrast 0.51
Selection.ShapeRange.PictureFormat.IncrementBrightness -0.48
' Einfügen zuende!
' Anfangzahl um 2 erhöhen
anfangzahl = anfangzahl + 2
' Zeilen-Schleife Ende
Next i
' Spaltenzahl um 1 erhöhen
asciispalte = asciispalte + 1
' Anfangszahl zurücksetzen
anfangzahl = zeilenschleifenanfang
' Spalten-Schleife Ende
Next h
' Warnungen wieder anschalten
Application.DisplayAlerts = True
End Sub
Gruß Emu