Danke Klaus

ja, gern: #If VBA7 Then Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As Long #Else Private Declare Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As Long, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If 'Global deklariert Dim strZiel As String Private Sub UserForm_Initialize() ' Dieses Makro lädt eine Datei aus dem Internet herunter und speichert sie lokal auf Ihrem Computer. ' Deklaration der Variablen Dim strUrl As String Dim lngErg As Long Dim ctrl As Control ' URL der herunterzuladenden Datei strUrl = "www.held-office.de/Downloads/Perlfee2023.jpg" strZiel = ThisWorkbook.Path & "\Perfee2023.jpg" ' Aufruf der API-Funktion URLDownloadToFile, um die Datei herunterzuladen lngErg = URLDownloadToFile(0, strUrl, strZiel, 0, 0) If lngErg = 0 Then Me.Image1.BorderStyle = fmBorderStyleNone Me.Image1.Picture = LoadPicture(strZiel) Me.Image1.PictureSizeMode = fmPictureSizeModeStretch Me.TXT_URL.Value = strUrl Me.Caption = "" Me.BackColor = RGB(240, 240, 240) End If For Each ctrl In Me.Controls ' Je nach Typ des Steuerelements wird die Formatierung festgelegt Select Case TypeName(ctrl) Case "TextBox" ' TextBox-Steuerelemente werden mit grauer Schriftfarbe ' und einer Schriftgröße von 10 formatiert. ctrl.Font.Size = 10 ctrl.ForeColor = RGB(128, 128, 128) ctrl.Enabled = False Case "Label" ' Label-Steuerelemente werden mit grauem Hintergrund, ' grauer Schriftfarbe und einer Schriftgröße von 12 formatiert. ctrl.BackColor = RGB(240, 240, 240) ctrl.Font.Size = 10 ctrl.ForeColor = RGB(128, 128, 128) ctrl.TextAlign = fmTextAlignLeft Case "CommandButton" ' CommandButton (OK-Schaltfläche) wird mit grünem Hintergrund, ' weißer Schriftfarbe und einer Schriftgröße von 11 formatiert. ctrl.BackColor = RGB(0, 100, 0) ctrl.ForeColor = RGB(255, 255, 255) ctrl.Font.Size = 11 End Select Next ctrl End Sub Private Sub cmd_ok_Click() Dim shp As Shape Dim rngTarget As Range ' Zielbereich für das Bild in der Tabelle festlegen Set rngTarget = Tabelle1.Range("B6") ' Bild aus dem Image-Steuerelement kopieren und in die Tabelle einfügen Set shp = Tabelle1.Shapes.AddPicture _ (strZiel, msoFalse, msoCTrue, rngTarget.Left, rngTarget.Top, -1, -1) ' Größe des Bildes anpassen, um in die Zelle zu passen shp.LockAspectRatio = msoTrue shp.Width = rngTarget.Width shp.Height = rngTarget.Height End Sub Private Sub cmd_Cancel_Click() Unload Me End Sub

Hi Martin, probier mal: ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ ThisWorkbook.Path & "\Bestand.xlsx" & ";Extended Properties=Excel 8.0;"

@@vba-kracherheld-office Vielen Dank für die Prompte Antwort! Leider aber kommt immer noch der selbe Fehler...🤔

@@MartinFriedli-jh4dl ich habe Dir meine Version mal zugemailt. Die tickt bei mir

so: Sub ExcelBereichAlsEmailVesenden2() Dim rngBereich As Range Dim objDoc As Object Dim lngZ As Long ' Den umliegenden Bereich der Zelle A1 identifizieren Set rngBereich = Tabelle1.Range("A1").CurrentRegion ' Einen Verweis zu Outlook setzen und leere E-Mail erstellen With CreateObject("Outlook.Application").CreateItem(0) ' E-Mail anzeigen .Display ' Den eigentlichen Textinhalt der E-Mail definieren .Body = "Der eigentliche Text des E-Mails..." ' Einen Verweis zum Word-Editor herstellen Set objDoc = .GetInspector.WordEditor ' Bereich kopieren rngBereich.Copy ' Den Cursor an das Ende des Dokuments setzen objDoc.Range.End = objDoc.Range.End - 1 ' Einfügen des Bereichs objDoc.Range.Paste ' Einfügen des zusätzlichen Textes objDoc.Range.InsertAfter vbCrLf & "Zusätzlicher Text hier..." ' Hier den zusätzlichen Text einfügen ' Adressat und Titel der E-Mail festlegen .To = "[email protected]" .Subject = "Titel des E-Mails" ' Zwischenablage leeren Application.CutCopyMode = False ' E-Mail versenden .Send End With End Sub

Super, vielen Dank. Werde ich testen😊

​@@vba-kracherheld-office Funktioniert leider nicht bei mir. Der Inhalt der Nachricht und die Tabellenzeilen werden nicht angezeigt. Lediglich der letzte Satz "Zusätzlicher Text hier..." ist zu sehen.

@@sogehts433 das ist echt etwas verzwickt, aber so geht es bei mir: Sub EmailErstellen() Dim OutlookApp As Object Dim Mail As Object Dim RangeToSend As Range Dim EmailBody As String ' Start Outlook-Anwendung Set OutlookApp = CreateObject("Outlook.Application") Set Mail = OutlookApp.CreateItem(0) ' E-Mail-Eigenschaften setzen With Mail .To = "[email protected]" .Subject = "Betreff der E-Mail" End With ' Einleitenden Text einfügen EmailBody = "Guten Tag," & vbCrLf & vbCrLf & _ "Hier sind die aktuellen Daten:" & vbCrLf & vbCrLf ' Bereich aus Excel-Tabelle einfügen Set RangeToSend = Sheets("Tabelle1").Range("A1:B10") ' Beispielbereich For Each cell In RangeToSend EmailBody = EmailBody & cell.Value & vbTab If cell.Column = RangeToSend.Columns.Count Then EmailBody = EmailBody & vbCrLf End If Next cell EmailBody = EmailBody & vbCrLf ' Abschließenden Text einfügen EmailBody = EmailBody & "Mit freundlichen Grüßen," & vbCrLf & "Max Mustermann" ' E-Mail senden With Mail .Body = EmailBody .Display ' Zum Anzeigen der E-Mail vor dem Senden '.Send ' Zum direkten Senden der E-Mail End With Set OutlookApp = Nothing Set Mail = Nothing End Sub

Hi, so z.B. Um die Größe der Bilder, die in das Arbeitsblatt eingefügt werden, zu ändern, müssen die Width und Height Parameter der Shapes.AddPicture Methode angepasst werden. Sub BilderEntfernen() Dim objShp As Shape With Tabelle2 For Each objShp In .Shapes If objShp.Type = 13 Then objShp.Delete End If Next objShp End With End Sub Sub BilderEinfuegen() Dim rngTreffer As Range Dim strBild As String Dim i As Integer Dim objShp As Shape Dim lngSpalte As Long Dim lngZeile As Long With Tabelle2 Call BilderEntfernen lngZeile = 4 lngSpalte = 1 For i = 0 To .ListBox1.ListCount - 1 If .ListBox1.Selected(i) = True Then Set rngTreffer = Tabelle1.Range("A:A").Find _ (what:=.ListBox1.List(i), lookat:=xlWhole) If Not rngTreffer Is Nothing Then strBild = ThisWorkbook.Path & "\" & _ rngTreffer.Offset(0, 1).Value & ".jpg" If Dir(strBild) <> "" Then ' Hier die Bildgröße anpassen Set objShp = Tabelle2.Shapes.AddPicture _ (Filename:=strBild, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=.Cells(lngZeile, lngSpalte).Left, _ Top:=.Cells(lngZeile, lngSpalte).Top, _ Width:=450, Height:=300) ' Anpassung der Bildgröße lngSpalte = lngSpalte + 6 If lngSpalte >= 12 Then lngZeile = lngZeile + 16 lngSpalte = 1 End If End If End If .ListBox1.Selected(i) = False End If Next i End With End Sub

hallo Nadir, magst Du mir Deine Datei mal mailen? Ich schaue es mir gerne na. Ist bestimmt nur eine Kleinigkeit. Mail an: [email protected]

Hi Achim, so: Sub UnikateInDictionary() Dim vardat As Variant, ObjDict As Object, lngZeile As Long, lngZeileMax As Long Debug.Print "Start V.3: " & Now With Tabelle1 .Range("C:C").Clear lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row Set ObjDict = CreateObject("Scripting.Dictionary") vardat = Tabelle1.Range("A1:A" & lngZeileMax).Value2 For lngZeile = 1 To UBound(vardat, 1) If vardat(lngZeile, 1) <> "" Then ObjDict(vardat(lngZeile, 1)) = Empty End If Next lngZeile vardat = WorksheetFunction.Transpose(ObjDict.keys()) .Range("C1").Resize(UBound(vardat, 1)).Value = vardat .Range("C:C").Sort key1:=.Range("C1"), order1:=xlAscending, Header:=xlNo End With Debug.Print "Ende V.3: " & Now & vbLf End Sub VG Bernd

@@vba-kracherheld-office Danke, Bernd! Das hat gefluppt. Prima!

Menü "Ansicht" - "Neues Fenster," dann Fenster so hinziehen, wie Du es brauchst. Mit der Tastenkombination "Windows-Fenster" + Pfeil nach links oder rechts kannst Du auch die Fenster "automatisch" anordnen. Für mich ist das super wichtig, damit ich sehe, was auf den Tabellen passiert, wenn ich im Einzelschrittmodus mit der Taste F8 Zeile für Zeile durch das Makro durchgehe.

@@vba-kracherheld-office Dabei gehen alle anderen Fixierungen verloren....😒

sowas in der Art? Sub SpaltenAnzeigenAusblenden() Dim wksTab As Worksheet Dim VarSpalten As Variant Dim i As Integer ' Arbeitsblatt mit der Tabelle festlegen Set wksTab = Tabelle1 ' Array mit den Nummern der sichtbaren Spalten festlegen VarSpalten = Array(1, 2, 4, 6, 7, 8, 9, 12, 19, 20, 21, 22, 24, 25) wksTab.Columns.Hidden = True ' Sichtbare Spalten einblenden For i = LBound(VarSpalten) To UBound(VarSpalten) wksTab.Columns(VarSpalten(i)).Hidden = False Next i End Sub

Ja, das geht auch. Ich wollte eben dass beide Arrays gleich dimensioniert sind. Danke aber für Deine Anmerkung.

Hallo. Das ist glaube ich nur in der ersten halben Stunde so. Bitte probiere das in einer Stunde nocheinmal. Vg Bernd

applocation.Commandbars("cells').reset noch ein Sieb

Hi Kjeld, das klingt spannend. Kannst Du mir dazu einmal eine Demodatei zukommen lassen?

Hallo Bernd, gerne ! Ich würde diese dann auf deine an deine Firmeneigene Email schicken. Vg Kjeld

@@KjeldSeegert Du hast Post. Habe das ganz nett hinbekommen

Hi, also wenn Du vor dem Refresh die Ereignissteuerung lahm legst, dann wird nichts dokumentiert. Application.EnableEvents=False dann Dein Refresh und dann wieder einschalten. Application.EnableEvents=True

Da fällt mir keine ein. Ich arbeite mit Wind 64 Bit und Office 32 Bit. Das tickt

Hi Detlef, ich bin mit dem VBA-Tanker Update immer eine paar Tage später dran. Ich lade Dir das Beispiel auf meinen GoogleDrive. drive.google.com/drive/folders/1jkDyfovJ1u__vIYpL0_H1u1EhErUFrIU?usp=drive_link LG Bernd

@@vba-kracherheld-office Vielen Dank Bernd

Hi, hier habe ich das beschrieben: kzbin.info/www/bejne/kKWboqN-fLeBapI

@@vba-kracherheld-office Oh ich Dussl, als das Video rausgekommen ist habe ich mir noch gedacht das hört sich genau nach dem an was ich suche aber dann wohl sofort wieder vergessen und nie angeschaut. Passt genau. Vielen Dank.

So der Download hat mittlerweile geklappt.. aber nur wenn ich in der strURL direkt den Freigabe Link einfüge

Was aber dann nicht klappt.. egal ob es eine PDF oder Excel ist die geladene Datei lässt sich nicht öffnen oder ist leer

Und das überschreiben funktioniert auch nicht.. da steigt das Makro aus

Komisch tut bei mir alles ohne Probleme. Hast Du die Version verwendet, die ich beim Download unter dem Video angegeben habe? @@theogerber1747

@@vba-kracherheld-office ja hab ich

interessante Idee. Muss ich mir mal ansehen. Wenn es klappt, mache ich ein Video.

Das wäre super.. das ist ein Baustein der mir für mein Vereinsprojekt fehlt

Bei mir war der standardmäßig drin.

Ein Array ist immer vom Typ Variant

Ich versuche mich gerade noch daran, die Monate in der Matrix durch konkrete Datum zu ersetzen. Muss ich hier die Variable lngSp umdeklarieren?

stimmt aber nicht. ich beantworte jedes e-Mail. hast Du mir an [email protected] geschrieben? Habe die Datei hochgeladen drive.google.com/drive/folders/13noNXbSkD-ZIzBu4rDEAennvU8TIQ2mr?usp=sharing

Hallo Herr Becker, das kann ich mangels SAP-Installation nicht so recht testen. Man müsste schauen, was im Fenstertitel der Excel-Anwendung steht und dann mittels API versuchen, den zu finden. In etwas so: Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" ( _ ByVal hWnd As LongPtr, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As LongPtr Const WM_CLOSE As Long = &H10 Sub CloseFileInExternalExcelInstance(ByVal windowTitle As String) Dim hWnd As LongPtr ' Find the window handle of the external Excel instance based on its window title hWnd = FindWindow("XLMAIN", windowTitle) If hWnd <> 0 Then ' Send the WM_CLOSE message to the window handle to close the file SendMessage hWnd, WM_CLOSE, 0, ByVal 0 Else MsgBox "External Excel instance not found.", vbExclamation End If End Sub Sub Aufruf() Dim externalExcelWindowTitle As String externalExcelWindowTitle = "Mappe1.xlsx - Excel" CloseFileInExternalExcelInstance externalExcelWindowTitle End Sub

sehr gut, danke

Hallo, ja dazu habe ich gerade ein Beispiel programmiert, dass ich in ca. einer Woche als Video mache. Wenn Du vorab schon mal reinschauen willst, dann schick mir kurz eine e-Mail an [email protected]

@@vba-kracherheld-office da komme ich gerne drauf zurück. Email kommt

Danke Chris

Super aufgepasst! Ein Fehler von mir.. danke für den Hinweis

@vba-kracherheld-office Wow! Wie schnell bist du denn? Hammer! Hast Du auch noch etwas zu meinem nachgetragenen 2. Part? Und noch n Gedicht! Wichtig fände ich noch den Hinweis, dass man in den VBA-Formeln Semikola durch Kommata ersetzen muss. Hab ich beim ersten Mal Stunden nach diesem Fehler gesucht? Oh ja! :D

oh ja, war Sonntag (-;. Das sollte natürlich in die Formel mit rein, danke!@@RueTheDuck Sub FilternUnter365Dynamisch() Dim Vardat As Variant Dim lngZeileMax As Long With tbl_Filter 'Zielbereich leeren und Format-Technisch vorbereiten .Range("I:J").ClearContents .Range("I:I").NumberFormat = "DD.MM.YYYY" 'die letzte, belegte Zeile in Spalte A ermitteln lngZeileMax = .Cells(.Rows.Count, 3).End(xlUp).Row 'Filterung simulieren und im Arbeitsspeicher ablegen Vardat = .Evaluate("=FILTER(B2:C" & lngZeileMax & ",C2:C" & lngZeileMax & "=H2)") 'Ausgabe des Arrays, wenn er gefüllt ist If Not IsError(Vardat) Then .Range("I2").Resize(UBound(Vardat, 1), _ UBound(Vardat, 2)).Value = Vardat Else .Range("I2").Value = "Katastrophe!" End If End With End Sub

@@vba-kracherheld-office Jetzt ist es rund. :)

Danke für Deine Aufmerksamkeit@@RueTheDuck

Hallo Jannik, ja, das geht rein theoretisch. Dann kannst Du den Fortschrittsbalken aber nur nach "Gefühl" füttern. ich bastle mal kurz was.. Moment..

so was in der Art: Private Sub UserForm_Activate() Me.ProgressBar1.Max = 100 Call Import Me.ProgressBar1.Value = 10 Call Konverierung Me.ProgressBar1.Value = 30 Call Verarbeitung Me.ProgressBar1.Value = 40 Call Ausgabe Me.ProgressBar1.Value = 80 Call Abschluss Me.ProgressBar1.Value = 95 Unload Me End Sub Hinter den calls wären dann die Prozeduren. Das Beispiel ist für den Einsatz des Standard-Fortschrittbalken von Microsoft.

Dazu habe ich folgendes im Internet gefunden: stackoverflow.com/questions/39521872/how-can-i-automatically-send-email-from-thunderbird-with-excel-vba

Danke für die schnelle Antwort. Ich werde es demnächst ausprobieren.