|
Hallo Gast74096,
tausend Dank für die schnelle Hilfe. Leider lässt sich die Funktion nicht einfügen. Bei "Option Explicit" sagt er mir " Fehler beim Kompilieren. Innerhalb einer prozedur ungültig".
Ich habe hier mal den gesamten Teil des VBA, in dem sich die Prozedur abspielt. Wo liegt das Problem? Ich bin leider kein gelernter VBAler, habe lediglich in den 80ern mal leidenschaftlich Basic programmiert und stecke jetzt in Excel fest... :-P
Viele Grüße, Martin
Private Sub Wochentag_auslesen(WT As String, Menue As Boolean, Wok As Boolean, Suppe As Boolean, Kita As Boolean)
Dim KZ As Integer 'Kopfzeile in Worksheet Daten
Dim vZ As Integer 'von Zeile im Worksheet Daten
Dim bZ As Integer 'bis Zeile im Worksheet Daten
Select Case WT
Case "Montag"
KZ = 15
vZ = KZ + 1
bZ = KZ + 50
End Select
Cells(zeile, 1) = Worksheets("Daten").Cells(KZ, 2)
Cells(zeile, 1).EntireRow.AutoFit
For i = vZ To bZ
If Worksheets("Daten").Cells(i, 2) <> Empty And Worksheets("Daten").Cells(i, 2) <> " " Then
If Worksheets("Daten").Cells(i, 1) Like "Menü*" Or Worksheets("Daten").Cells(i, 1) = "WOK" Or Worksheets("Daten").Cells(i, 1) = "Suppe" Or Worksheets("Daten").Cells(i, 1) = "Kita" Then
'Menülinie schreiben
If Worksheets("Daten").Cells(i, 1) Like "Menü*" Then
If Menue = True Then
'Menübezeichnung schreiben
Cells(zeile, 3) = Worksheets("Daten").Cells(i, 2)
Range(Cells(zeile, 3), Cells(zeile, 3)).Select
Selection.Font.Bold = False
Range(Cells(zeile, 1), Cells(zeile, 3)).Select
End If
End If
'Bild einfügen
Option Explicit
Sub Example()
Dim shp As Shape
Dim strFilename As String
With Worksheets("Daten")
strFilename = "c:\Bilder\" & .Cells(i, "J").Value & ".jpg"
Set shp = CreatePictureAtCellPos(strFilename, .Range(3, "C"), 100, 100)
'...
End With
End Sub
Public Function CreatePictureAtCellPos( _
Filename As String, Cell As Excel.Range, _
Width As Single, Height As Single _
) As Shape
'Fügt das Bild an der Zellposition in angegebene Breite und Höhe ein.
'Es wird nur die Verknüpfung zum Bild gespeichert, das Bild selbst also nicht (so bleibt die Mappe schlank).
Set CreatePictureAtCellPos = Cell.Worksheet.Shapes.AddPicture( _
Filename, _
LinkToFile:=True, _
SaveWithDocument:=False, _
Left:=Cell.Left, _
Top:=Cell.Top, _
Width:=Width, _
Height:=Height)
End Function
Range(Cells(zeile, 1), Cells(zeile, 3)).Select
'Selection.Borders(xlEdgeTop).LineStyle = xlContinuous 'Rahmen Oben
Call Allergene_auslesen(Worksheets("Daten").Cells(KZ, 2), Worksheets("Daten").Cells(i, 1))
zeile = zeile + 1
Rows(zeile).RowHeight = 6
End If
End If
End If
End If
Next i
End Function
|