Grafiken, Schleife?, kein "range" u. "select"

Hallo!

Mein Problem:
Habe eine Spalte(K9:55) in die Werte eingetragen werden. Wird ein Wert überschritten (aus Spalte I oder J) wird eine Grafik nach Abschluss der Eingabe per Button eingefügt.
Kann man auch per Schleife prüfen? Außerdem würde ich gerne das ganze "select" und "range" eliminieren.
Zudem funktioniert die nummerische Prüfung nicht ganz...
Der Code ist irrsinnig lang und unübersichtlich...

Codeauszug:
If Not IsNumeric(ActiveSheet.Range("K9")) Then
MsgBox "Bitte eine Zahl eingeben..."
ElseIf ActiveSheet.Range("K9") <> "" Then
If ActiveSheet.Range("K9").Value < ActiveSheet.Range("I9").Value Then
Range("L9").Select
ActiveSheet.Pictures.Insert("G:\...\achtung.bmp").Select
End If

If ActiveSheet.Range("K9").Value > ActiveSheet.Range("J9").Value Then
Range("L9").Select
ActiveSheet.Pictures.Insert("G:\...\achtung.bmp").Select
End If
End If

Hier eine weitere Spalte (P) in die Grafiken eingefügt werden:
Der Wert (in Spalte O) ist immer gleich (vielleicht hier Schleife?!)

Codeauszug:
If Not IsNumeric(ActiveSheet.Range("O9")) Then
MsgBox "Bitte eine Zahl eingeben..."
ElseIf ActiveSheet.Range("O9") <> "" Then
If ActiveSheet.Range("O9").Value > 20 Then
Range("P9").Select
ActiveSheet.Pictures.Insert("G:\...\achtung.bmp").Select
End If
End If

Im vor raus Danke an alle die sich mit meinem Problem befassen.
Für jede Anregung oder Hilfe bin ich dankbar

Gruß

Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub PictureInsert() Dim rTestZelle As Range Set rTestZelle = [k9] If (IsError(rTestZelle.Value) = True) Then MsgBox "Error in der Tets-Zelle " & _ rTestZelle.Address(rowabsolute:=False, columnabsolute:=False) ElseIf (IsNumeric(rTestZelle.Value) = False) Then MsgBox "Bitte eine Zahl eingeben..." ElseIf (CStr(rTestZelle.Value) <> "") Then If rTestZelle.Value < [I9].Value Then [L9].Activate ActiveSheet.Pictures.Insert ("C:\Temp\pic.bmp") ElseIf rTestZelle.Value < [J9].Value Then [L9].Activate ActiveSheet.Pictures.Insert ("C:\Temp\pic2.bmp") End If End If End Sub

Option Explicit

Private Const TESTVALUE% = 20
' es werden die Zellen im Range o9:o15 getestet, ob > TESTVALUE% oder < TESTVALUE%
' und je nach dem ob grosser oder kleiner wird ein bild in die Nachbarzelle zugegeben und dessen Grosse wird der Host-Zelle angepast. Gruss q
' wird
' hier starten
Public Sub PictureInsertInRange()
Dim rTestRange As Range
Dim rZelle As Range

Set rTestRange = [o9:o15]

For Each rZelle In rTestRange.Cells
Call TestAndInsert(rZelle)
Next rZelle
End Sub


Private Sub TestAndInsert(ByVal rPar As Range)
Dim rTestZelle As Range
Dim Sh As Object
Set rTestZelle = rPar
If (IsError(rTestZelle.Value) = True) Then
MsgBox "Error in der Tets-Zelle " & _
rTestZelle.Address(rowabsolute:=False, columnabsolute:=False)
ElseIf (IsNumeric(rTestZelle.Value) = False) Then
MsgBox "Bitte eine Zahl eingeben..."
ElseIf (CStr(rTestZelle.Value) <> "") Then
If rTestZelle.Value < TESTVALUE Then
rTestZelle.Offset(0, 1).Activate
ActiveSheet.Pictures.Insert("C:\Temp\pic.bmp").Select
Set Sh = Selection
With Sh
.Height = rTestZelle.Height
.Width = rTestZelle.Offset(0, 1).Width
End With
ElseIf rTestZelle.Value > TESTVALUE Then
rTestZelle.Offset(0, 1).Activate
ActiveSheet.Pictures.Insert("C:\Temp\pic2.bmp").Select
Set Sh = Selection
With Sh
.Height = rTestZelle.Height
.Width = rTestZelle.Offset(0, 1).Width
End With
End If
End If
End Sub

Beliebteste Forumthreads (12 Monate)

Grafiken, Schleife?, kein "range" u. "select"

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

150 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Grafiken, Schleife?, kein "range" u. "select"

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

150 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread