20.06.2020

Daten von Excel nach Access - Abfragen per SQL ausführen...

Daten aus Excel sollen nach Access - in eine temporäre Tabelle - kopiert werden. Von dort wird eine Tabelle als Archiv befüllt. Es wird eine Anfüge- und eine Aktualisierungsabfrage per SQL ausgeführt, um zusätzliche Datensätze, oder Änderungen, zu übertragen. Kommentare im Code.

Data from Excel should be copied to Access - into a temporary table. From there a table is filled as an archive. A SQL append and update query is executed to transfer additional data records or changes. Comments in the code.

Hier noch eine Beispieldatei / Here's a sample file:
Daten von Excel nach Access - Abfragen per SQL ausführen...[ZIP 70 KB]

' Variaqblendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2020
' Purpose   : Von Excel nach Access - Anfügeabfrage...
'--------------------------------------------------------------------------
Public Sub Main_1()
    'Objektvariable für Datenbank
    Dim objDBank As Object
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Ab Excel 2007 wird die "neue" Engine genommen
    ' Access-Datei ist im gleichen Verzeichnis wie DIESE Excel-Datei
    ' Datenbank wird geöffnet
    If Val(Application.Version) >= 12 Then
        Set objDBank = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "Sample.accdb")
    Else
        Set objDBank = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "Sample.mdb")
    End If
    ' Der Code bezieht sich auf ein bestimmtes Objekt, hier die Datenbank
    ' Alles was sich auf dieses "With" bezieht MUSS mit einem Punkt beginnen
    With objDBank
        ' Inhalt der temporären Tabelle mit
        ' Namen "TransferToAccess" wird gelöscht
        .Execute "DELETE * FROM TransferToAccess"
        ' Der Inhalt des Tabellenblattes "TransferToAccess" wird in
        ' die Access-Datei in die Tabelle "TransferToAccess" eingefügt
        ' Tabellenname in Excel und Name der Tabelle in Access sind hier
        ' gleich - müssen es aber natürlich nicht sein
        ' Feldnamen in der Tabelle in Access sind aber GLEICH, wie die
        ' Überschriften in der Tabelle in Excel
        .Execute "INSERT INTO TransferToAccess SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & _
            ThisWorkbook.FullName & "].[TransferToAccess$]"
        ' Anfügeabfrage - per SQL-Befehl, Datensatz wird aber nur eingefügt, wenn der Inhalt von ID
        ' in der Tabelle "TransferToAccess" noch nicht im Feld ID in der Tabelle "Archiv" vorhanden ist
        .Execute "INSERT INTO Archiv SELECT * FROM TransferToAccess WHERE ID NOT IN (SELECT ID FROM Archiv)"
    End With
    ' Datenbank offen, dann schliessen
    If Not objDBank Is Nothing Then objDBank.Close
Fin:
    ' Setze die Objektvariable auf Nothing
    Set objDBank = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main_2
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2020
' Purpose   : Von Excel nach Access - Aktualisierungsabfrage...
'--------------------------------------------------------------------------
Public Sub Main_2()
    'Objektvariable für Datenbank
    Dim objDBank As Object
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Ab Excel 2007 wird die "neue" Engine genommen
    ' Access-Datei ist im gleichen Verzeichnis wie DIESE Excel-Datei
    ' Datenbank wird geöffnet
    If Val(Application.Version) >= 12 Then
        Set objDBank = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "Sample.accdb")
    Else
        Set objDBank = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "Sample.mdb")
    End If
    ' Der Code bezieht sich auf ein bestimmtes Objekt, hier die Datenbank
    ' Alles was sich auf dieses "With" bezieht MUSS mit einem Punkt beginnen
    With objDBank
        ' Inhalt der temporären Tabelle mit
        ' Namen "TransferToAccess" wird gelöscht
        .Execute "DELETE * FROM TransferToAccess"
        ' Der Inhalt des Tabellenblattes "TransferToAccess" wird in
        ' die Access-Datei in die Tabelle "TransferToAccess" eingefügt
        ' Tabellenname in Excel und Name der Tabelle in Access sind hier
        ' gleich - müssen es aber natürlich nicht sein
        ' Feldnamen in der Tabelle in Access sind aber GLEICH, wie die
        ' Überschriften in der Tabelle in Excel
        .Execute "INSERT INTO TransferToAccess SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & _
            ThisWorkbook.FullName & "].[TransferToAccess$]"
        ' Aktualisierungsabfrage - per SQL-Befehl, Datensatz wird aber nur geändert, wenn der Inhalt von ID
        ' in der Tabelle "TransferToAccess" der Gleiche ist, wie der Inhalt von ID in der Tabelle "Archiv"
        .Execute "UPDATE Archiv INNER JOIN TransferToAccess ON Archiv.ID = TransferToAccess.ID " & _
            "SET Archiv.SpalteA = TransferToAccess.SpalteA, " & _
            "Archiv.SpalteB = TransferToAccess.SpalteB, " & _
            "Archiv.SpalteC = TransferToAccess.SpalteC, " & _
            "Archiv.SpalteD = TransferToAccess.SpalteD, " & _
            "Archiv.SpalteE = TransferToAccess.SpalteE, " & _
            "Archiv.SpalteG = TransferToAccess.SpalteG, " & _
            "Archiv.SpalteH = TransferToAccess.SpalteH, " & _
            "Archiv.SpalteI = TransferToAccess.SpalteI, " & _
            "Archiv.SpalteJ = TransferToAccess.SpalteJ"
    End With
    ' Datenbank offen, dann schliessen
    If Not objDBank Is Nothing Then objDBank.Close
Fin:
    ' Setze die Objektvariable auf Nothing
    Set objDBank = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub
'Die folgenden Makros werden NUR zum testen benötigt, man BRAUCHT dazu die Beispieldatei!!!!!!!
Public Sub Main_3()
    Dim lngTMP As Long
    With Tabelle1
        lngTMP = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A" & lngTMP & ":J" & lngTMP).AutoFill Destination:=.Range("A" & lngTMP & ":J" & lngTMP + 1)
    End With
End Sub
Public Sub Main_4()
    With Tabelle1
        .Range("A2").Value = "A_2222222"
        .Range("B3").Value = "B_3333333"
        .Range("C4").Value = "C_4444444"
        .Range("D5").Value = "D_5555555"
        .Range("E6").Value = "E_6666666"
        .Range("G7").Value = "G_7777777"
        .Range("H8").Value = "H_8888888"
        .Range("I9").Value = "I_9999999"
        .Range("J10").Value = "J_1010101"
    End With
End Sub
Public Sub Main_5()
    Tabelle1.Cells.Clear
    Tabelle2.UsedRange.Copy Tabelle1.Range("A1")
End Sub

28.03.2020

Daten - aus zu öffnenden Dateien - nach Spalte D aufteilen, dann speichern...

Bezugnehmend auf einen Blogeintrag aus dem Januar 2014 (https://vbanet.blogspot.com/2014/01/daten-spalte-c-nach-monat-in-neue.html) sollen Daten auf Tabellenblätter verteilt werden. Diese Dateien müssen zunächst über einen Dialog aus einer Masterdatei ausgewählt/geöffnet werden. Dabei soll die Möglichkeit bestehen, eine Datei oder mehrere Dateien auszuwählen. Die ersten 3 Spalten sind ausgeblendet. Kriterienspalte ist D. Der Bereich ist nicht sortiert und er reicht von A1 bis Qx. Nach dem die Tabellenblätter erstellt wurden, soll ein Speicherndialog aufgerufen werden. Der Dateiname setzt sich zusammen aus Datum & Uhrzeit & altem Namen. Wie geht das?

With reference to a blog entry from January 2014 (https://vbanet.blogspot.com/2014/01/daten-spalte-c-nach-monat-in-neue.html), data is to be distributed on spreadsheets. These files must first be selected/opened from a master file via a dialog. It should be possible to select one or more files. The first 3 columns are hidden. Criteria column is D. The range is not sorted and it reaches from A1 to Qx. After the worksheets have been created, a save dialog should be called. The file name consists of date & time & old name. How to do this?
Translated with www.DeepL.com/Translator (free version)

Hier noch eine Beispieldatei / Here's a sample file:
Daten - aus zu öffnenden Dateien - nach Spalte D aufteilen, dann speichern...[ZIP 520 KB]

Code gehört in ein Modul / Code belongs in a module:

' Variablendeklaration erfordelich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.03.2020
' Purpose   : Daten nach Spalte D in Tabellenblätter aufteilen
' Purpose   : In auszuwählenden Dateien - mit Dateiauswahldialog
' Purpose   : Mehrfachauswahl - also Auswahl mehrerer Dateien möglich
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim CriteriaSheet As Worksheet
    Dim SourceSheet As Worksheet
    Dim strQuellColumn As String
    Dim strBisColumn As String
    Dim rngCriterion As Range
    Dim vntReturn As Variant
    Dim wksNew As Worksheet
    Dim wksTMP As Worksheet
    Dim wkbBook As Workbook
    Dim lngLastRow As Long
    Dim lngReturn As Long
    Dim lngCalc As Long
    ' Welche Spalte beinhaltet das Kriterium bzw. nach welcher Spalte soll aufgeteilt werden
    strQuellColumn = "D"
    ' Der Bereich der kopiert werden soll bzw. wie weit geht meine Tabelle - hier bis Spalte Q
    strBisColumn = "Q"
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ChDir ThisWorkbook.Path
    ' Dateiauswahldialog mit Filter auf XLSX, XLSM, XLSB und Alle _MEHRFACHAUSWAHL möglich
    vntReturn = Application.GetOpenFilename(FileFilter:="XLSX-Format (*.xlsx), " & _
        "*.xlsx, XLSM-Format (*.xlsm), *.xlsm, XLSB-Format (*.xlsb), *.xlsb, Alle (*.*), *.*", MultiSelect:=True)
    ' Wenn NICHT auf Abbrechen geklickt wurde dann - ist es ein Array...
    If IsArray(vntReturn) Then
        ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
        With Application
            ' Das Bildschirmaktualisierung wird unterbrochen
            .ScreenUpdating = False
            ' Ereignisroutinen werden deaktiviert
            .EnableEvents = False
            ' Auslesen der momentanen Einstellung für die Berechnung
            lngCalc = .Calculation
            ' Setzen der Berechnung auf "Manuell"
            .Calculation = xlCalculationManual
            '  Eingabeaufforderungen und Warnmeldungen unterdrücken
            .DisplayAlerts = False
        End With
        For lngReturn = LBound(vntReturn) To UBound(vntReturn)
            ' Öffne die ausgewählte Datei OHNE die Links zu aktualisieren UND Schreibgeschützt
            Set wkbBook = Workbooks.Open(vntReturn(lngReturn), 0, True)
            ' Schleife über jeder Tabellenblatt in der eben geöffneten Datei
            For Each wksTMP In wkbBook.Worksheets
                ' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
                If wksTMP.Index > 1 Then
                    ' ... lösche es
                    wksTMP.Delete
                End If
            Next wksTMP
            ' Tabellenblatt mit den Grunddaten - hier das erste Tabellenblatt.
            ' Alle anderen sind ja gelöscht!
            Set SourceSheet = wkbBook.Worksheets(1)
            ' Ein Kriterientabellenblatt wird hinzugefügt
            Set CriteriaSheet = wkbBook.Worksheets.Add
            ' Und an das Ende verschoben
            CriteriaSheet.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
            ' Ermittelt die letzte belegte Zeile im Quelltabellenblatt Splate D
            lngLastRow = SourceSheet.Range(strQuellColumn & Rows.Count).End(xlUp).Row
            ' Kopiere mit dem Spezialfilter die Liste OHNE Mehrfache (Unique=True)
            SourceSheet.Range(strQuellColumn & "1:" & strQuellColumn & lngLastRow).AdvancedFilter _
                Action:=xlFilterCopy, CopyToRange:=CriteriaSheet.Range("A1"), Unique:=True
            ' Leerzeilen löschen
            CriteriaSheet.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            ' Das erste Kriterium zuweisen
            Set rngCriterion = CriteriaSheet.Range("A2")
            ' So lange schleifen, bis kein Kriterium mehr vorhanden ist
            While rngCriterion.Value <> ""
                ' Neues Tabellenblatt
                Set wksNew = wkbBook.Worksheets.Add
                ' Ans Ende stellen
                wksNew.Move After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
                ' Über Spezialfilter alle passenden Kriterienzeilen (von A bis Q) kopieren
                SourceSheet.Range("A1:" & strBisColumn & lngLastRow).AdvancedFilter _
                    Action:=xlFilterCopy, _
                    CriteriaRange:=rngCriterion.Offset(-1).Resize(2), _
                    CopyToRange:=wksNew.Range("A1")
                ' Tabellenblatt mit Kriterium benennen
                wksNew.Name = rngCriterion.Value
                ' Das erledigte Kriterium löschen
                rngCriterion.EntireRow.Delete
                ' Setze die Objektvariablen auf Nothing
                Set rngCriterion = Nothing
                Set wksNew = Nothing
                ' Das nächste Kriterium zuweisen
                Set rngCriterion = CriteriaSheet.Range("A2")
            ' Und weiter im Text...
            Wend
            ' Wenn ein Kriterientabellenblatt vorhanden ist, lösche es
            If Not CriteriaSheet Is Nothing Then CriteriaSheet.Delete
            ' Gehe zum Quelltabellenblatt nach A1
            Application.Goto SourceSheet.Range("A1"), True
            ' SpeichernUnter-Dialog aufrufen. Name mit Datum und Zeit vorangestellt vorgeben
            Application.Dialogs(xlDialogSaveAs).Show ThisWorkbook.Path & "\" & Format(Now, "ddMMyyyy_hhmmss_") & wkbBook.Name
            ' Wenn die Quelldatei noch offen ist - dann schließen OHNE speichern
            If Not wkbBook Is Nothing Then wkbBook.Close False
        Next lngReturn
    End If
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set wkbBook = Nothing
    Set CriteriaSheet = Nothing
    Set SourceSheet = Nothing
    Set rngCriterion = Nothing
    Set wksNew = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

29.02.2020

API - Ordner erstellen, Zeichen prüfen, Umlaute konvertieren...

Einen Ordner erstellen (immer mit bestimmtem Unterordner). Ungültige Zeichen sollen entfernt werden und Umlaute konvertiert (Ä = Ae usw.). Im Beispiel wird der Wert aus Zelle A1 genommen.

Create a folder (always with a specific subfolder). Invalid characters should be removed and umlauts converted (Ä = Ae etc.). In the example the value from cell A1 is taken.

Hier noch eine Beispieldatei / Here's a sample file:
API - Ordner erstellen, Zeichen prüfen, Umlaute konvertieren...[XLSB 25 KB]

Code gehört in ein Modul / Code belongs in a module:

' Variablendeklaration erforderlich!
Option Explicit
' Bedingte Kompilierung 32Bit/64Bit - Ordner vorhanden? Ordner anlegen.
#If Win64 Then
    Private Declare PtrSafe Function PathFileExists Lib "shlwapi.dll" _
        Alias "PathFileExistsA" (ByVal pszPath As String) As LongPtr
    Private Declare PtrSafe Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#Else
    Private Declare Function PathFileExists Lib "shlwapi.dll" Alias _
        "PathFileExistsA" (ByVal pszPath As String) As Long
    Private Declare Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If
' Pfad anpassen!!!!! Abschließender Backslash NICHT vergessen!!!!
Const strPath As String = "C:\Temp\"
' Name des Subfolder, der immer zusätzlich erstellt wird
' Abschließender Backslash NICHT vergessen!!!!
Const strSubFolder As String = "Archiv\"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.02.2020
' Purpose   : API - Ordner erstellen - Name in A1 - ungültige Zeichen weg
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strFolder As String
    On Error GoTo Fin
    ' Bezieht sich auf das Tabellenblatt "Tabelle1"
    With ThisWorkbook.Worksheets("Tabelle1")
        ' Wenn in A1 nichts steht - auch keine Leerzeichen, dann...
        If Trim(.Cells(1, 1).Value) <> "" Then
            ' Pfad- und Dateiname zusammen zu lang?
            If Not Len(strPath & .Cells(1, 1).Value) > 250 Then
                ' Nicht erlaubte Zeichen im Ordnername entfernen
                ' WENN keine Umlaute erlaubt sein sollen, dann einfach
                ' PATTERN ändern und strFolder = fncSyntax(strFolder)
                ' auskommentieren!!!!!
                strFolder = fncCheckName(.Cells(1, 1).Value)
                ' Umlaute ersetzen
                strFolder = fncSyntax(strFolder)
                ' Prüfe, ob abschließender Backslash vorhanden
                If Right(strFolder, 1) <> "\" Then
                    ' Wenn nicht vorhanden, setze Einen am Ende
                    strFolder = strFolder & "\"
                End If
                ' Ordner schon da?
                If PathFileExists(strPath & strFolder) <> 0 Then
                    MsgBox "Ordner vorhanden!"
                Else
                    ' Ordner erstellen
                    MakeSureDirectoryPathExists _
                        (strPath & strFolder & strSubFolder)
                    MsgBox "Erstellt: " & strPath & strFolder & strSubFolder
                End If
            Else
                MsgBox "Pfad- und Dateiname zu lang!"
            End If
        Else
            MsgBox "Zelle A1 leer!"
        End If
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : fncCheckName
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.02.2020
' Purpose   : REGEXP - ungültige Zeichen Ordnername entfernen...
'--------------------------------------------------------------------------
Private Function fncCheckName(ByVal strTMP As String) As String
    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    With objRegExp
        .Global = True
        .Pattern = "[^\wäÄöÖüÜß]"
        '.Pattern = "[^\w]"
        '.Pattern = "[^A-Za-z0-9_äÄöÖüÜß]"
        fncCheckName = .Replace(strTMP, "")
    End With
    Set objRegExp = Nothing
End Function
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : fncSyntax
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.02.2020
' Purpose   : Replacen - Umlaute und "ß" ersezten...
'--------------------------------------------------------------------------
Private Function fncSyntax(ByVal strText As String) As String
    strText = Replace(strText, "Ä", "Ae")
    strText = Replace(strText, "Ö", "Oe")
    strText = Replace(strText, "Ü", "Ue")
    strText = Replace(strText, "ß", "ss")
    strText = Replace(strText, "ä", "ae")
    strText = Replace(strText, "ö", "oe")
    strText = Replace(strText, "ü", "ue")
    fncSyntax = strText
End Function

27.02.2020

Text und Ampel nach PowerPoint...

Der Inhalt von einigen Zellen (im Beispiel von A7 bis A22) soll nach Powerpoint kopiert werden. In eine vorhandene Datei mit schon bestehenden TextBoxen. Wie geht das? Dann soll noch eine Ampel als Bild auf eine andere Folie kopiert werden.

The contents of some cells (in the example from A7 to A22) are to be copied to Powerpoint. To an existing file with already existing TextBoxes. How to do this? Then a traffic light is to be copied as an image onto another slide.

Hier noch eine Beispieldatei / Here's a sample file:
Text und Ampel nach PowerPoint...[ZIP 58 KB]

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
' Speichername der Datei
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
' Leeres Slide in PowerPoint
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation
Dim objPP As Object
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 27.02.2020
' Purpose   : PowerPoint - TextBoxen befüllen, Ampel als Grafik kopieren...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim objPPPres As Object
    Dim objPPDoc As Object
    Dim objShape As Object
    Dim intLeft As Integer
    Dim intTMP As Integer
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Vorhandene Präsentation öffnen - im gleichen Pfad wie die Exceldatei
            Set objPPPres = .Presentations.Open _
                (Filename:=ThisWorkbook.Path & _
                Application.PathSeparator & "Template1.ppt")
            Set objPPDoc = objPPPres.Slides(1)
            ' Schleife um 16 Zellinhalte nach 16 TextBoxen in PP zu kopieren
            For intTMP = 7 To 22
                objPPDoc.Shapes(intTMP - 6).TextFrame.TextRange.Text = " Inhalt aus " & _
                    ThisWorkbook.Worksheets(1).Cells(intTMP, 1).Value
            Next intTMP
            ' Ampel auf Slide 2 kopieren
            Set objPPDoc = objPPPres.Slides(2)
            ThisWorkbook.Worksheets(1).Range("D3:D5").CopyPicture
            Set objShape = objPPDoc.Shapes.Paste
            ' Plazieren
            With objShape
                .Top = 20
                .Height = 40
                .Width = 65
                .Left = 20
            End With
            ' Unter neuem Namen speichern
            objPPPres.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & strPPSave & _
                Format(Now, "_dd_MM_yyyy_hh_mm_ss")
            ' Präsentation Schliessen
            objPPPres.Close
            ' PP beenden
            .Quit
        End With
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objShape = Nothing
    Set objPPDoc = Nothing
    Set objPPPres = Nothing
    Set objPP = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 27.02.2020
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

26.02.2020

Outlook - Aufgaben - Tasks nach Excel importieren...

Aufgaben aus Outlook in Excel importieren. Es sollten natürlich schon Aufgaben in Outlook angelegt sein, um diesen Code zu testen. Im Anhang ist noch eine weitere Datei (Outlook_Tasks_Create_Delete_Change_EntryID_and_StoreID.xlsb [36 KB]). Eine Spielerei, die nicht ganz fertig ist, aber vielleicht den Ein oder Anderen Denkansatz liefert.

Import tasks from Outlook into Excel. Of course, tasks should already be created in Outlook to test this code. There is one more file attached (Outlook_Tasks_Create_Delete_Change_EntryID_and_StoreID.xlsb [36 KB]). A gimmick that is not quite finished, but may give you some ideas.

Hier noch eine Beispieldatei / Here's a sample file:
Outlook - Aufgaben - Tasks nach Excel importieren...[ZIP 52 KB]

Code gehört in ein Modul / Code belongs in a module:

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : © Case (Ralf Stolzenburg)
' Date      : 26.02.2020
' Purpose   : Outlook - Aufgaben (Tasks) in Excel importieren...
'--------------------------------------------------------------------------
Sub Main()
    ' Variablen- Konstantendeklaration
    Const olTaskInProgress = 1 ' Die Aufgabe ist in Bearbeitung
    Const olTaskNotStarted = 0 ' Die Aufgabe wurde noch nicht gestartet
    Const olTaskComplete = 2   ' Die Aufgabe ist abgeschlossen
    Const olTaskDeferred = 4   ' Die Aufgabe wurde zurückgestellt
    Const olTaskWaiting = 3    ' Die Aufgabe wartet auf eine andere Person
    Const olFolderTasks = 13   ' Konstante für Aufgaben/Tasks
    Dim objOutMail As Object
    Dim objTask As Object
    Dim strTMP As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    ' Fehleranzeige und Events ausschalten - Berechnung auf manuell setzen
    ' Vorher den aktuellen Zustand auslesen
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Eintrag ab Zeile 2
    lngTMP = 2
    ' Die Objektvariable objOutMail wird mit dem
    ' Folder Aufgaben/Tasks befüllt
    Set objOutMail = CreateObject("Outlook.Application") _
        .GetNamespace("MAPI").GetDefaultFolder(olFolderTasks)
    ' Inhalt von Tabelle1 wird ab Zeile 2 gelöscht
    Tabelle1.Rows("2:" & Tabelle1.Rows.Count).ClearContents
    ' Gehe durch jedes vorhandene Item in den Aufgaben/Tasks
    For Each objTask In objOutMail.Items
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier das Objekt Tabelle1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        ' Tabelle1 ist der CODENAME des Tabellenblattes - siehe...
        ' https://vbanet.blogspot.com/search/label/Codename
        With Tabelle1
            ' Betreff in A2 bzw. A2 folgende eintragen
            .Cells(lngTMP, 1) = objTask.Subject
            ' Erstelldatum in B2 bzw. B2 folgende eintragen
            .Cells(lngTMP, 2) = objTask.CreationTime
            ' Startdatum in C2 bzw. C2 folgende eintragen
            .Cells(lngTMP, 3) = objTask.StartDate
            ' Fälligkeitsdatum in D2 bzw. D2 folgende eintragen
            .Cells(lngTMP, 4) = objTask.DueDate
            ' Erinnerungsdatum in E2 bzw. E2 folgende eintragen
            .Cells(lngTMP, 5) = objTask.ReminderTime
            ' Besitzer in F2 bzw. F2 folgende eintragen
            .Cells(lngTMP, 6) = objTask.Owner
            ' Kategorie in G2 bzw. G2 folgende eintragen
            .Cells(lngTMP, 7) = objTask.Categories
            ' Priorität in H2 bzw. H2 folgende eintragen
            ' olImportanceHigh - 2 - Das Element ist mit hoher Wichtigkeit gekennzeichnet
            ' olImportanceLow - 0 - Das Element ist mit niedriger Wichtigkeit gekennzeichnet
            ' olImportanceNormal - 1 - Das Element ist mittlerer Wichtigkeit gekennzeichnet
            .Cells(lngTMP, 8) = objTask.Importance
            ' Abfrage des Status und Zuweisung an die Variable strTMP
            Select Case objTask.Status
                Case olTaskComplete: strTMP = "Erledigt"
                Case olTaskDeferred: strTMP = "Zurückgestellt"
                Case olTaskInProgress: strTMP = "In Bearbeitung"
                Case olTaskNotStarted: strTMP = "Noch nicht begonnen"
                Case olTaskWaiting: strTMP = "Noch wartend"
            End Select
            ' Zustand von Status ausgeben
            .Cells(lngTMP, 9) = strTMP
            ' Eine Zeile hochzählen
            lngTMP = lngTMP + 1
            ' Die Variable strTMP leeren
            strTMP = ""
        End With
    ' Nächstes Item
    Next objTask
    ' Automatische Spaltenbreite
    Tabelle1.Columns("A:I").AutoFit
Fin:
    ' Setze die Objektvariable auf Nothing
    Set objOutMail = Nothing
    ' Die Applikation aufwecken/Fehleranzeige/Events
    ' Berechnung auf vorher ausgelesenen Zustand setzen
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
    ' und die Fehlerbeschreibung aus
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders"
' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderManagedEmail = 29 (&H1D)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderRssFeeds = 25 (&H19)
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSuggestedContacts = 30 (&H1E)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olFolderToDo = 28 (&H1C)
'Const olPublicFoldersAllPublicFolders = 18 (&H12)

Daten von Excel nach Access - Abfragen per SQL ausführen...

Daten aus Excel sollen nach Access - in eine temporäre Tabelle - kopiert werden. Von dort wird eine Tabelle als Archiv befüllt. Es wird eine...