Automatische Aktualisierung mittels VBA & Makros

Sub NewDatabase()

    Dim conn As Object

    Dim rs As Object

    Dim query As String

    Dim ws As Worksheet

    Dim pt As PivotTable

    Dim pCache As PivotCache

    Dim tbl As ListObject

    Dim newDSN As String

    Dim newUsername As String

    Dim newPassword As String

    

    ' Show the UserForm

    frmDatabaseInput.Show

    

    ' Get the input values from the UserForm

    newDSN = frmDatabaseInput.txtDSN.Value

    newUsername = frmDatabaseInput.txtUser.Value

    newPassword = frmDatabaseInput.txtPassword.Value

    

    ' If the user clicks cancel or leaves the input blank, exit the sub

    If newDSN = "" Or newUsername = "" Or newPassword = "" Then

        MsgBox "Keine vollständigen Verbindungsdaten eingegeben. Das Makro wird beendet.", vbExclamation

        Exit Sub

    End If

    

    ' Connection string to your ODBC data source

    Dim connStr As String

    connStr = "DSN=" & newDSN & ";UID=" & newUsername & ";PWD=" & newPassword & ";"

    

    ' Debug-Ausgabe der Verbindungszeichenfolge

    Debug.Print "Verbindungszeichenfolge: " & connStr

    

    ' Create a new connection

    Set conn = CreateObject("ADODB.Connection")

    

    ' Error handling to catch connection issues

    On Error GoTo ConnectionError

    

    ' Debug-Ausgabe vor dem Verbindungsaufbau

    Debug.Print "Versuche, eine Verbindung herzustellen..."

    

    conn.Open connStr

    

    ' Debug-Ausgabe nach erfolgreichem Verbindungsaufbau

    Debug.Print "Verbindung erfolgreich hergestellt."

    

    ' Loop through each worksheet and update the queries

    For Each ws In ThisWorkbook.Worksheets

        ' Skip the sheet if it doesn't have any ListObjects

        If ws.ListObjects.Count > 0 Then

            ' Unhide the sheet if it is hidden

            ws.Visible = xlSheetVisible

            

            For Each tbl In ws.ListObjects

                ' Clear existing data

                tbl.DataBodyRange.ClearContents

                

                ' Define the query based on the table name

                Select Case tbl.Name

                    Case "backlogTable"

                        query = "SELECT * FROM backlogTable;"

                    Case "costsTable"

                        query = "SELECT * FROM costsTable;"

                    Case "deliveryAmountsTable"

                        query = "SELECT * FROM deliveryAmountsTable;"

                    Case "deliveryTable"

                        query = "SELECT * FROM deliveryTable;"

                    Case "investmentTable"

                        query = "SELECT * FROM investmentTable;"

                    Case "openOrderTable"

                        query = "SELECT * FROM openOrderTable;"

                    Case "orderAmountsTable"

                        query = "SELECT * FROM orderAmountsTable;"

                    Case "orderTable"

                        query = "SELECT * FROM orderTable;"

                    Case "productionAmountsTable"

                        query = "SELECT * FROM productionAmountsTable;"

                    Case "productionTable"

                        query = "SELECT * FROM productionTable;"

                    Case "productTable"

                        query = "SELECT * FROM productTable;"

                    Case "productVersionsTable"

                        query = "SELECT * FROM productVersionsTable;"

                    Case "roundsTable"

                        query = "SELECT * FROM roundsTable;"

                    Case "stockTable"

                        query = "SELECT * FROM stockTable;"

                    Case "tierInfo"

                        query = "SELECT * FROM tierInfo;"

                    Case Else

                        MsgBox "Unbekannte Tabelle: " & tbl.Name, vbExclamation

                        GoTo NextTable

                End Select

                

                ' Execute the query and fill the table

                Set rs = CreateObject("ADODB.Recordset")

                rs.Open query, conn

                

                ' Add the data to the table

                tbl.HeaderRowRange.Cells(1, 1).CopyFromRecordset rs

                

                ' Close the recordset

                rs.Close

                Set rs = Nothing

                

                ' Hide the sheet again

                ws.Visible = xlSheetVeryHidden

NextTable:

            Next tbl

        End If

    Next ws



    ' Refresh all pivot tables

    For Each ws In ThisWorkbook.Worksheets

        For Each pt In ws.PivotTables

            Set pCache = pt.PivotCache

            pCache.Refresh

        Next pt

    Next ws

    

    MsgBox "Abfragen und Daten wurden erfolgreich aktualisiert.", vbInformation

    conn.Close

    Set conn = Nothing

    Exit Sub

    

ConnectionError:

    MsgBox "Fehler beim Herstellen der Verbindung: " & Err.Description, vbCritical

    Debug.Print "Fehler beim Herstellen der Verbindung: " & Err.Description

    Set conn = Nothing

End Sub