Excel Über Macro Bilder ohne Link einbetten?

Hallo zusammen,

ich möchte für einen Kunden eine Produktübersicht mit Bildern erstellen. Die Bilder ziehe ich mir über folgenden Code:

Sub InsertPics()
  Dim Rw&, PFAD$, Datei$, Bild As Shape
  PFAD = "C:\test\"
  With ActiveSheet
    For Rw = 32 To 47
      Datei = .Range("G" & Rw) & ".jpg"
      If Dir(PFAD & Datei) <> vbNullString Then
        .Pictures.Insert (PFAD & Datei)
        Set Bild = .Shapes(.Shapes.Count)
        Bild.LockAspectRatio = msoFalse
        Bild.Left = .Range("A" & Rw).Left
        Bild.Top = .Range("A" & Rw).Top
        Bild.Width = .Range("A" & Rw).Width
        Bild.Height = .Range("A" & Rw).Height
      End If
    Next
  End With
End Sub

Welcher auf wunderbar funktioniert. Einziges Problem: Die Bilder werden nur verlinkt und nicht kopiert. Sobald ich die Datei versende, sind die Bilder nicht mehr sichtbar. Wie muss ich den Code verändern, um die Bilder gleich zu kopieren? Ist das möglich?

Danke für jede Antwort.

3 Antworten

geri3d

Nutzer, der sehr aktiv auf gutefrage ist

im Thema Microsoft Excel

10.02.2021, 12:39

So was ähliches habe ich erst neulich gebraucht:

Sub LogoEinfügen()
    On Error Resume Next
    Dim fd
    Dim fileName
        
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
 
        With fd
            .Filters.Clear
            .Filters.Add "Alle Dateien", "*.*?", 1
            .Title = "Wählen Sie eine Bilddatei"
            .AllowMultiSelect = False
            '.InitialFileName = ""
            If .Show = True Then
                fileName = .SelectedItems(1)
            End If
        End With
    
    With ActiveSheet.Pictures.Insert(fileName)
        .Top = 0
        .Left = 0
        .Height = 90#
        .Width = 180#
    End With
    
End Sub

Woher ich das weiß:eigene Erfahrung

Deepdiver

10.02.2021, 12:02

So wie ich das sehe, hast du die Bilder auf dem Rechner gespeichert und rufst di darüber ab.

Wenn du nun die Datei nun versenden willst, feht der Bezug zu den Bildern.

Anders ist es, wenn du die Bilder auf einer Cloud abspeicherst und alle anderen darauf zu greifen können.

tobiholic

Beitragsersteller

10.02.2021, 12:14

Das habe ich auch schon überlegt, mir ist es aber lieber, wenn die Bilder sich in der Exceldatei befinden. Gibt es dazu eine Lösung?

Deepdiver

10.02.2021, 13:18

@tobiholic

Nur über OLE-Objekte

IchMalWiederXY

Von gutefrage auf Grund seines Wissens auf einem Fachgebiet ausgezeichneter Nutzer

Microsoft Excel

10.02.2021, 12:40

Dateien die "in" Excel selbst vorhanden sein sollen sind als "OLE" Objekt hinzuzufügen.
Versuch dies mal:
ActiveSheet.OLEObjects.Add(Filename:="C:\test.jpg", Link:=False, DisplayAsIcon:=False).Select 'ggf DisplayAsIcon =True
Per VBA können diese internen OLE Objekte auch wieder auf einem Zielrechner lokal extrahiert werden.

tobiholic

Beitragsersteller

10.02.2021, 13:10

Danke! Meine IT Kentnisse reichen leider nicht aus, um das in meinen aktuellen Code zu übertragen. Wenn ich statt ActiveSheet. ActiveSheet.OLEO eintrage, erhalte ich leider eine Fehlermeldung..

IchMalWiederXY

10.02.2021, 13:13

@tobiholic

Dieser Code muss in einem "Modul" (oder auch in der Code Sektion zu einem Worksheet) stehen. (NICHT in einer Excel Zelle)
VBA Editor Öffnen: ALT+F11 drücken.
Dort an der gewünschten Stelle einfügen. Zugegeben, ein paar weitere VBA Kennnisse sind nötig.

tobiholic

Beitragsersteller

10.02.2021, 13:18

@IchMalWiederXY

ja ganz so schlimm ist es auch nicht :D Soweit bin ich - mir ist nur nicht klar, wie ich den in meinen aktuellen Code einbinde..

Etwa so?

Sub InsertPics()

  Dim Rw&, PFAD$, Datei$, Bild As Shape

  PFAD = "C:\test\"
  With ActiveSheet.OLEObjects.Add(fileName:="C:\test.jpg", Link:=False, DisplayAsIcon:=False).Select
    For Rw = 32 To 47
      Datei = .Range("G" & Rw) & ".jpg"
      If Dir(PFAD & Datei) <> vbNullString Then
        .Pictures.Insert (PFAD & Datei)
        Set Bild = .Shapes(.Shapes.Count)
        Bild.LockAspectRatio = msoFalse
        Bild.Left = .Range("A" & Rw).Left
        Bild.Top = .Range("A" & Rw).Top
        Bild.Width = .Range("A" & Rw).Width
        Bild.Height = .Range("A" & Rw).Height
      End If
    Next
  End With
End Sub

IchMalWiederXY

10.02.2021, 13:28

@tobiholic

Nein. Das OLE Object ist "NICHT" in einer Zelle. Damit kann es auf diese Weise nicht angezeigt werden. Es BEFINDET sich NUR in Excel.
Wie man nun in einer PictureBox (ActiveX Element) in Excel das OLE Object zur Anzeige bringt habe ich auch noch nie gemacht. Sollte aber möglich sein.
Die muss die Position des OLE Objectes IN Excel nutzen und NICHT mehr den Pfad zu deinem Rechner. GOOGLE mal
"VBA Display OLE Object in PictureBox"

tobiholic

Beitragsersteller

10.02.2021, 13:29

@IchMalWiederXY

alles klar - vielen Dank für deine Geduld! Echt super und hilft mir gerade extrem weiter :)

Ähnliche Beiträge

Excel VBA Formel zum Speichern als PDF funktioniert nicht immer. Wie beheben?

Hey. Ich habe einen Code zum Speichern von Tabellenblättern als PDF in Ordnern und Unterordnern, die erstellt werden. Ich habe noch ein paar mal daran herum gebaut, also sieht der Code möglicherweise nicht sehr clean aus.

Ich füge den Code Stückweise ein, weil er zu viele Zeichen hat.

Mein Problem ist nun: Auf meinem PC funktioniert der Code super, ohne zwischenfälle. Ich habe nun die Excel-Datei schon mehrmals per USB auf einen anderen Rechner gezogen und den Dateipfad angepasst. Dennoch funktioniert er hier nur teilweise, da nur Oberordner und Unterordner erstellt werden. Der zweite Unterordner und die PDF Dokumente bleiben weg. Vielleicht kann mir hierbei jemand helfen. Einen schönen 4. Advent euch noch!

...zum Beitrag

Excel Macro: Formel dynamisch machen, um Zellenbereich auszuwählen?

Liebe Community,

ich habe folgendes Macro in meiner Excel Tabelle. Es funktioniert auch wunderbar, bis auf die Tatsache, dass dort der Tabellenbereich aus der fremden Excel-Datei definiert ist.

Leider sind es nicht immer 239 Zeilen. Mal mehr und mal weniger. Dass es bei A7 anfängt, das stimmt schon. Wie müsste ich die Formel ändern, damit Excel sich automatisch anpasst?

Vielen lieben Dank im Voraus!

Es handelt sich um diese Zeile wbQuelle.Worksheets(1).Range("A7:I239").Copy

Sub Quelle()

Dim sPfad As String
Dim wbQuelle As Workbook
Dim zelle As Range

sPfad = "C:\Users\Beispiel\Desktop\Irgendeine Datei\Daten\Daten.xlsx"

If Dir(sPfad) <> "" Then

Set wbQuelle = Workbooks.Open(sPfad)

wbQuelle.Worksheets(1).Range("A7:I239").Copy ThisWorkbook.Worksheets(3).Range("B2")

wbQuelle.Close savechanges:=False

End If

End Sub

...zum Beitrag

Makro mit VBA in Excel zerschossen, brauche dringend Hilfe!?

Hallo zusammen,

vorab schonmal, nein ich habe hier absolut 0% Ahnung hiervon und brauche dringend Hilfe!

Ich habe auf der Arbeit bei einer wichtigen Excel Datei eine neue Spalte eingefügt, was dafür gesorgt hat, dass eine wichtige Spalte rechts davon weiter nach rechts verschoben wurde um eine Zelle.

In dieser Spalte wurden Enddatum eingetragen und diese wurden mit einem Makro über VBA Absteigend von jüngerem Datum oben, nach späteren Datum nach unten hin sortiert.

Nachdem ich die neue Spalte zugefügt habe, funktionierte eins nach dem anderen nicht mehr richtig und ich war so dumm zu versuchen das Makro minimal anzugleichen, sodass es funktioniert und habe es dann getestet.

Dadurch habe ich es nur schlimmer gemacht...

Zudem kann ich jetzt nicht mal mehr in der Tabelle scrollen, zumindest in diesem Reiter, in einem anderen Reiter unten, kann ich scrollen in der Datei.

Der Text in VBA Stand jetzt:

Sub Sortieren()

' Sortieren Makro

Rows("3:500").Select

Range("B3").Activate

ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Add Key:=Range( _

"H4:Hl34"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

xlSortNormal

With ActiveWorkbook.Worksheets("Übersicht").Sort

.SetRange Range("A3:L500")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

ActiveWindow.SmallScroll Down:=3

ActiveSheet.Range("$A$3:$L$97").AutoFilter Field:=12, Criteria1:="="

ActiveWindow.SmallScroll Down:=-12

End Sub

...zum Beitrag

Name + User?

Hallo,

was müsste ich hier anpassen? Ich komme mit der Fehler Meldung nicht zurecht.

Private Declare 36 GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Function GetNTUserA() As String
  
 Dim sBuffer As String
 Dim LSize As Long
 Dim user As String
  
 sBuffer = Space$(255)
 LSize = Len(sBuffer)
  
 Call GetUserName(sBuffer, LSize)
  
 If LSize > 0 Then
  user = Left$(sBuffer, LSize - 1)
 Else
  user = vbNullString
 End If
  
 GetNTUserA = user
  
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
   
    If Target.Column = 6 Then
    Target.Offset(0, 11).Value = Date
  End If
      
    If Target.Column = 6 Then
    Target.Offset(0, 10).Value = GetNTUserA
  End If

End Sub

...zum Beitrag

Wie kann Makros auf mehrere Zellen anwenden?

Hallo zusammen

Ich habe von einem von euch diesen Code für mein Problem erhalten.

Public dMerk As Double

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$A$7" And IsNumeric(Target) Then

Application.EnableEvents = False

On Error Resume Next

Range("A7").Value = dMerk + Target.Value

dMerk = Range("A7").Value

Application.EnableEvents = True

On Error GoTo 0

End If

End Sub

Jetzt möchte ich diesen jedoch nicht nur auf diese eine Zellle anwenden, sondern auf viele verschiedene. Wie kann ich das machen ohne für jede Zelle das Makro kopieren und den Bezug ändern muss.

Danke im voraus

...zum Beitrag

VBA Dateiauswahl - Bei Abbruch Laufzeitfehler 5, jemand Ideen?

Hallo zusammen,

was müsste ich hinzufügen, um den Laufzeitfehler 5 zu umgehen? Wenn ich den VBA-Code ausführe, öffnet sich das Fenster für den Import von DAT-Dateien. Drücke ich auf Abbrechen, erscheint der Laufzeitfehler 5. Vermerkt wird der Code "Set F = fs.GetFolder(strPfad)". Wo und welchen Code müsste ich hinzufügen, um den Fehler zu beheben? Vielen Dank im Voraus. :)

Sub Schaltfläche1_Klicken()
'
'
'*** Öffnen von DAT-Dateien
Dim strText As String, strFilter As String

strText = "Bitte eine Auswertung Auswählen"
strFilter = "DAT-Dateien (*.DAT), *.DAT"""
strAuswahl = Application.GetOpenFilename(strFilter, 1, strText)
strPfad = Pfad_ermitteln(strAuswahl)
'
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFolder(strPfad)
Set fc = F.Files

If ActiveSheet Is Nothing Then Workbooks.Add
For Each File In fc
    Zeile = Cells(65000, 1).End(xlUp).Row + 2
    strEinfügen = Cells(Zeile, 1).Address
    strAuswahl = File.Path

    'Einfügen
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & strAuswahl _
        , Destination:=Range(strEinfügen))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileDecimalSeparator = "."
        .TextFileThousandsSeparator = ","
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
  End With
  Range(strEinfügen).QueryTable.Delete
Next
End Sub
_______________________________

 Function Pfad_ermitteln(ByVal strAuswahl As String) As String
 
 For i = Len(strAuswahl) To 1 Step -1
    If Mid(strAuswahl, i, 1) = "\" Then
        Pfad_ermitteln = Left(strAuswahl, i - 1)
        Exit Function
    End If
Next
End Function

...zum Beitrag

Excel: Verbessertes Logging mit VBA Makro?

Hallo Zusammen

ich verwende im Moment ein kurzes Makro, um Änderungen in einem Tabellenblatt zu loggen.

Es registriert aber nur einzelne Änderungen, nicht multi-selektion oder Löschen von Spalten. Kann ich das mit separaten Privaten Subs übernehmen?

Und kann ich aufnehmen, was die Target- und "PreVal"-Adresse war (Offset 4+5)

Code:

Dim PreVal
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
PreVal = Target.Value
 
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  
    On Error GoTo 0
    
    If Target.Value <> PreVal Then
        With Sheets(2).Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = Now
            .Offset(1, 1) = PreVal
            .Offset(1, 2) = Target.Value
            .Offset(1, 3) = Environ("Username")
        End With
    End If
 
End Sub

...zum Beitrag

VBA: Zwei Spalten mit Wert multiplizieren und dann addieren mit Hilfe von Makros

Hallöchen,

ich habe folgendes Problem Ich habe zwei Spalten die ich jeweils miteinander addieren möchte. Doch bevor ich diese addiere, möchte ich Spalte B mit dem Wert aus der TextBox1 multiplizieren und Spalte C mit dem Wert aus Textbox2. Danach sollen beide Spalten miteinander addiert und dann sortiert werden. Spalte D ist in diesem Fall die Ergebnisspalte. Das Programm hat auch schon funktioniert, jedoch habe ich vorher nur die spalten addiert und sortiert.

HIer mein bereits geschriebener Code:

Private Sub CommandButton1_Click()



' Prüfen ob Lastspitzen eingetragen wurden, ansonsten Fehlermeldung

        If TextBox1.Value = "" Or TextBox2.Value = "" Then
        MsgBox "Bitte geben Sie eine Lastspitze ein!"
     
Else
        
Dim wks As Excel.Worksheet
Dim lngLetzteZeile As Long
Dim Last1 As Integer
Dim Last2 As Integer
Last1 = TextBox1.Value
Last2 = TextBox2.Value  

Set wks = ActiveWorkbook.Worksheets("Vergleich")


With wks
 
lngLetzteZeile = .Cells(.Rows.Count, "B").End(xlUp).Row
If lngLetzteZeile < 15 Then Exit Sub

 With .Range("D15:D" & lngLetzteZeile)
 'berechne: D := B + C
 .FormulaR1C1 = "=RC[-2]*Last1+RC[-1]*Last2"
 'Formeln durch deren Ergebnis ersetzen
 .Value = .Value
 End With
 
With .Range("B15:D" & lngLetzteZeile)
 .Sort Key1:=.Cells(2), Order1:=xlDescending, _
 DataOption1:=xlSortTextAsNumbers, _
 SortMethod:=xlPinYin
End With

End With
End If


End Sub

...zum Beitrag

VBA | UserForm öffnen, sobald Excel-Zelle (die eine Formel enthält) = 2?

Hallo,

Excel-VBA....

ich benötige Hilfe beim Thema UserForm öffnen und ständige Abfrage.

Ich habe eine Zelle mit einer Formel, der Wert, welcher raus kommt soll verglichen werden und bei z.b höher als 2 soll eine User Form geöffnet werden.

Kann mir da wer helfen? Ich bin komplett auf dem Holzweg..

Der Code:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$T$6" Then
If UCase(Target.Value) > 2 Then NewUserForm.Show
End If

End Sub

Devo

...zum Beitrag

Excel VBA Button Enable?

Hallo Freunde,

Ich habe einen Button in Excel implementiert, der sichtbar sein soll wenn meine Zelle A1 die Zahl 2 enthält.

Der Code dafür lautet:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  On Error GoTo ErrHandler
  Dim rngButton1 As Integer
  rngButton1 = A1
  If rngButton1 = 2 Then
  CommandButton1.Enabled = False
  Else
  CommandButton1.Enabled = True
  End If
  Application.EnableEvents = True
Exit Sub
ErrHandler:
Application.EnableEvents = True
End Sub

Der Code funktioniert an und für sich, es kommt zu keiner Fehlermeldung.
Aber der Button bleibt egal was ich einstelle, Sichtbar.

Wo liegt der Fehler?

...zum Beitrag

Excel Makro, PDF versenden, Anhang klappt nicht?

Hallo, ich würde gerne eine Rechnung mit einem Makro erstellen. Soweit klappt das auch und die Mail öffnet sich auch, aber diese wird nicht als Anhang hinzugefügt. Ich komme leider nicht drauf. Ich denke, es liegt daran, dass er die Datei nicht findet, aber ich wüsste keinen Lösungsansatz. Hier der Code:

Dim Result As VbMsgBoxResult

Sub RechnungsnrUndDrucken()

Sheets("Rechnung_Video").Select

[D15] = [D15] + 1 'Rechnungsnummer 1 hochzählen

Dim sCC As String

Dim sName As String

Dim sText As String

Dim sObject As String

Dim sCompany As String

Dim sRefNr As String

Dim sTempFileName As String

If (CStr(ThisWorkbook.ActiveSheet.Name) = "Rechnung") Then

Result = MsgBox("Rechnung fertig?", vbApplicationModal Or vbQuestion Or vbYesNo)

If Result = vbNo Then Exit Sub

End If

Const DateiPfad = "C:\Temp\"

Dim DateiName As String

DateiName = DateiPfad & Range("C15") & Range("D15") & ".pdf"

Range("A1:F54").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

DateiName, Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=False

Dim Nachricht As Object, OutApp As Object

Dim AWS As String

Set OutApp = CreateObject("Outlook.Application")

AWS = strFileName

'InitializeOutlook = True

Set Nachricht = OutApp.CreateItem(0)

With Nachricht

.Subject = "" & Range("A1") & "_" & Range("C15") & Range("D15")

.GetInspector.display

'.Attachments.Add ("C:\Temp\" & Range("C15") & Range("D15") & ".pdf")

End With

Set OutApp = Nothing

Set Nachricht = Nothing

End Sub

...zum Beitrag

Beim ändern einer bestimmten Zelle Makro erneut ausführen?

Hallo,

ich habe folgendes Anliegen: Ich möchte in Excel mit VBA etwas machen. Hier einmal der Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("j10")) Is Nothing Then
    Select Case Range("j10").Value
        Case "manuell"
            Range("s7:u7").ClearContents
        Case "Anfang & Ende"
            Range("s7").Value = Worksheets("PEPStauchung").Range("d2").Value
    End Select
End If
End Sub

Ich möchte, dass, wenn ich in Zelle S6 einen Wert ändere, das ganze erneut durchgeführt wird.

Wie binde ich das ein? Vielen Dank!!!

Syrena

...zum Beitrag

VBA Code Erklärung

Guten Abend zusammen. Könnte mir jemand weiterhelfen bei diesem Code. Was macht er genau in Excel? Also Die einzelnen Schritte die er durchläuft,.

Option Explicit

Public Sub Double_Red()
Dim lngZeile As Long
Dim lngZeilenSprung As Long
Dim strSuchwert As String

lngZeile = Cells(Rows.Count, 4).End(xlUp).Row

  For lngZeilenSprung = lngZeile To 1 Step -1
    strSuchwert = Cells(lngZeilenSprung, 4).Value
      If Application.WorksheetFunction.CountIf(Range(Cells(1, 4), Cells(lngZeile, 4)), strSuchwert) <> 1 Then
        Cells(lngZeilenSprung, 4).Interior.ColorIndex = 3
      End If
  Next lngZeilenSprung

End Sub

...zum Beitrag

Ich benötige einen Makro, um ausgewählte Filter beim Schliessen zurück zu setzen. Aber mit dem Blattschutz funktioniert das nicht mehr. Kann mir jemand helfen?

Ich habe bisher diesen Makro benutzt:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        With wksSheet
            If .AutoFilterMode Then
                If .FilterMode Then
                    .ShowAllData
                End If
            End If
        End With
    Next wksSheet
    ThisWorkbook.Save
End Sub

...zum Beitrag

Was möchtest Du wissen?

Deine Frage stellen