21.06.2013

ADO - Tabellenblätter - Anzahl - Geschlossene Datei...

Frage: Aus einer geschlossenen Datei benötige ich die Anzahl der Tabellenblätter. Wie geht das?

From a closed file I need the number of worksheets. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
ADO - Tabellenblätter - Anzahl - Geschlossene Datei...[ZIP 90 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 21.06.2013
' Purpose   : ADO - Tabellenblätter - Anzahl - Geschlossene Datei...
'--------------------------------------------------------------------------
Public Sub Main()
    MsgBox fncADOSheetCount(ThisWorkbook.Path & _
        Application.PathSeparator & "Sheet_50.xls")
End Sub
Private Function fncADOSheetCount(ByVal strFileName As String) As Integer
    Dim objConn As Object
    Dim objCat As Object
    Set objConn = CreateObject("ADODB.Connection")
    With objConn
        .CursorLocation = 3 ' = adUseClient
        If Val(Application.Version) >= 12 Then
            .Provider = "Microsoft.ACE.OLEDB.12.0;" & _
                "Extended Properties=""Excel 12.0;HDR=YES"";" & _
                "Data Source=" & strFileName & ";"
        Else
            .Provider = "Microsoft.Jet.OLEDB.4.0;" & _
                "Extended Properties=Excel 8.0;" & _
                "Data Source=" & strFileName & ";"
        End If
        .Open
    End With
    Set objCat = CreateObject("ADOX.Catalog")
    Set objCat.ActiveConnection = objConn
    fncADOSheetCount = objCat.Tables.Count ' Anzahl Tabellenblätter
    Set objCat = Nothing
    If Not objConn Is Nothing Then
        If objConn.State = 1 Then objConn.Close
    End If
    Set objConn = Nothing
End Function

20.06.2013

Word - Dokumente mit Hyperlinks - alle nach Excel...

Frage: Aus vielen Worddokumenten eines Verzeichnisses sollen alle Hyperlinks nach Excel kopiert werden. Ausgabe soll sein: Spalte A Dateiname (Pfad in Kommentar), Spalte B Hyperlink wie in Word dargestellt (muss anklickbar sein), Spalte C die Hyperlinkadresse und Spalte D den angezeigten Text. Wie geht das?

From many Word documents in a directory all hyperlinks should be copied to Excel. Output should be: Column A file name (path in comment) Column B Hyperlink (must be clickable) as shown in Word, the hyperlink address in column C and column D the displayed text. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Word - Dokumente mit Hyperlinks - alle nach Excel...[ZIP 200 KB]

Option Explicit
Dim blnTMP As Boolean
Dim objApp As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2013
' Purpose   : Aus Worddokumenten Hyperlinks nach Excel kopieren...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Dimensionieren der Variablen
    Dim objDocument As Object
    Dim intHLink As Integer
    Dim lngLastRow As Long
    Dim strFile As String
    Dim strPath As String
    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
    ' Pfad anpassen - fester Pfad vorgeben
    'strPath = "C:\Temp\Word\"
    ' Pfad anpassen - Worddateien sind im gleichen
    ' Verzeichnis wie diese Exceldatei
    strPath = ThisWorkbook.Path & Application.PathSeparator
    ' Die Wordapplikation sichtbar starten
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        strFile = Dir$(strPath & "*.doc*", vbDirectory)
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier Sheet1 = der CodeName der Tabelle
        ' im deutschen Excel in der Regel Tabelle1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With Sheet1
            ' Schleife bis keine Datei mehr vorhanden
            Do While strFile <> ""
                ' Worddokument öffnen und der Objektvariablen zuweisen
                Set objDocument = objApp.Documents.Open _
                    (strPath & strFile)
                    ' Alle Hyperlinks durchlaufen
                    For intHLink = 1 To objDocument.Hyperlinks.Count
                        ' Letzte belegte Zeile plus 1
                        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                        ' Dateiname schreiben Spalte A
                        .Cells(lngLastRow, 1).Value = strFile
                        ' Kommentar hinzufügen Spalte A
                        .Cells(lngLastRow, 1).AddComment
                        ' Kommentartext schreiben Spalte A
                        .Cells(lngLastRow, 1).Comment.Text Text:=strPath
                        ' Hyperlink schreiben Spalte B wie in Word (anklickbar)
                        .Cells(lngLastRow, 2).Value = _
                            objDocument.Hyperlinks(intHLink).TextToDisplay
                        ' Hyperlink in Excel setzen Spalte B
                        .Cells(lngLastRow, 2).Hyperlinks.Add _
                            Anchor:=.Cells(lngLastRow, 2), _
                            Address:=objDocument.Hyperlinks(intHLink).Address
                        ' Hyperlinkadresse schreiben Spalte C
                        .Cells(lngLastRow, 3).Value = _
                            objDocument.Hyperlinks(intHLink).Address
                        ' Hyperlink in Excel setzen Spalte C
                        .Cells(lngLastRow, 3).Hyperlinks.Add _
                            Anchor:=.Cells(lngLastRow, 3), _
                            Address:=objDocument.Hyperlinks(intHLink).Address
                        ' Angezeigter Text schreiben Spalte D
                        .Cells(lngLastRow, 4).Value = _
                            objDocument.Hyperlinks(intHLink).TextToDisplay
                    Next intHLink
                ' Worddokument ohne speichern schlissen
                objDocument.Close False
                ' Die nächste Datei nehmen
                strFile = Dir$()
                ' Setze die Objektvariable auf Nothing
                Set objDocument = Nothing
            Loop
            ' Spalte A:C optimale Breite setzen
            .Columns("A:C").AutoFit
        End With
    Else
        ' Application auf PC nicht vorhanden
        MsgBox "Application not installed!"
    End If
Fin:
    ' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
    If Not objDocument Is Nothing Then objDocument.Close False
    ' Wenn die Applikation noch offen ist - schliessen
    ' Aber nur, wenn sie nicht vorher schon offen war
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren
    Set objDocument = Nothing
    Set objApp = 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 "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

03.06.2013

DAO - alle MDB-Dateien eines Ordners auslesen...

Frage: Aus allen Dateien (mdb) werden die Daten einer bestimmten Tabelle ausgelesen. Diese sollen in Excel ausgewertet werden. Die Feldnamen dürfen nur einmal in der ersten Zeile eingetragen werden. Wie geht das?

From all files (mdb) data from a particular table are read. This should be evaluated in Excel. The field names can be entered only once in the first line. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
DAO - alle MDB-Dateien eines Ordners auslesen...[ZIP 3 MB]

Option Explicit
'-----------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.06.2013
' Purpose   : DAO Accessdatenbank - Alle Daten in Excel ausgeben SQL...
'-----------------------------------------------------------------------------
' Getestet in Excel 2007/2010/2013 - Access muss NICHT installiert sein
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx
Sub Main()
    ' Dimensionieren der Variablen
    Dim strMDBFile As String
    Dim intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    Dim blnTMP As Boolean
    Dim strSQL As String
    Dim strDAO As String
    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
    ' Prüfe die Excelversion
    If Val(Application.Version) >= 12 Then
        strDAO = "DAO.DBEngine.120"
    Else
        strDAO = "DAO.DBEngine.36"
    End If
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier Sheet1 = der CodeName der Tabelle
    ' im deutschen Excel in der Regel Tabelle1
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With Sheet1
        ' Einlesen des ersten Dateinamens
        strMDBFile = Dir$(ThisWorkbook.Path & Application.PathSeparator & "*.mdb")
        ' Hier wird in einer Schleife jede mdb-Datei geöffnet
        Do While strMDBFile <> ""
            Set objDBank = CreateObject(strDAO).OpenDatabase _
                (ThisWorkbook.Path & Application.PathSeparator & strMDBFile)
            ' SQL String erstellen - Alle Daten aus der Tabelle "customerdata"
            strSQL = "SELECT * FROM customerdata"
            ' Fülle die Objektvariable "objRSet" mit dem RecordSet
            ' erstellt aus der SQL-Anweisung
            Set objRSet = objDBank.OpenRecordset(strSQL)
            ' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
            If blnTMP = False Then
                For intCount = 0 To objRSet.Fields.Count - 1
                    .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
                Next intCount
                ' Überschrift Fett
                .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
                blnTMP = True
            End If
            'Trage den Inhalt des Recordset ab A2 folgende ein
            .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset objRSet
            ' Schliesse die Datenbank
            If Not objDBank Is Nothing Then objDBank.Close
            ' Setze die Objektvariablen auf Nothing
            Set objRSet = Nothing
            Set objDBank = Nothing
            ' Einlesen des nächsten Dateinamens
            strMDBFile = Dir$()
        Loop
        ' Ideale Breite der Spalten A - D
        .Columns("A:D").AutoFit
    End With
Fin:
    ' Schliesse die Datenbank
    If Not objDBank Is Nothing Then objDBank.Close
    ' Setze die Objektvariablen auf Nothing
    Set objRSet = Nothing
    Set objDBank = 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

Mit Ordnerauswahldialog / With folder selection dialog:

Option Explicit
'-----------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 03.06.2013
' Purpose   : DAO Accessdatenbank - Alle Daten in Excel ausgeben SQL...
'-----------------------------------------------------------------------------
' Getestet in Excel 2007/2010/2013 - Access muss NICHT installiert sein
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx
Sub Main_1()
    ' Dimensionieren der Variablen
    Dim strListing As String
    Dim strMDBFile As String
    Dim intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    Dim blnTMP As Boolean
    Dim strSQL As String
    Dim strDAO As String
    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
    ' Ordnerauswahl
    If funcDirectory(strListing) <> "" Then
        ' Prüfe die Excelversion
        If Val(Application.Version) >= 12 Then
            strDAO = "DAO.DBEngine.120"
        Else
            strDAO = "DAO.DBEngine.36"
        End If
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier Sheet1 = der CodeName der Tabelle
        ' im deutschen Excel in der Regel Tabelle1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With Sheet1
            ' Einlesen des ersten Dateinamens
            strMDBFile = Dir$(ThisWorkbook.Path & Application.PathSeparator & "*.mdb")
            ' Hier wird in einer Schleife jede mdb-Datei geöffnet
            Do While strMDBFile <> ""
                Set objDBank = CreateObject(strDAO).OpenDatabase _
                    (ThisWorkbook.Path & Application.PathSeparator & strMDBFile)
                ' SQL String erstellen - Alle Daten aus der Tabelle "customerdata"
                strSQL = "SELECT * FROM customerdata"
                ' Fülle die Objektvariable "objRSet" mit dem RecordSet
                ' erstellt aus der SQL-Anweisung
                Set objRSet = objDBank.OpenRecordset(strSQL)
                ' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
                If blnTMP = False Then
                    For intCount = 0 To objRSet.Fields.Count - 1
                        .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
                    Next intCount
                    ' Überschrift Fett
                    .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
                    blnTMP = True
                End If
                'Trage den Inhalt des Recordset ab A2 folgende ein
                .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset objRSet
                ' Schliesse die Datenbank
                If Not objDBank Is Nothing Then objDBank.Close
                ' Setze die Objektvariablen auf Nothing
                Set objRSet = Nothing
                Set objDBank = Nothing
                ' Einlesen des nächsten Dateinamens
                strMDBFile = Dir$()
            Loop
            ' Ideale Breite der Spalten A - D
            .Columns("A:D").AutoFit
        End With
    Else
        MsgBox "No directory was selected!"
    End If
Fin:
    ' Schliesse die Datenbank
    If Not objDBank Is Nothing Then objDBank.Close
    ' Setze die Objektvariablen auf Nothing
    Set objRSet = Nothing
    Set objDBank = 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
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator
        .Title = "Directory"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" Then strDirectory = strDirectory & "\"
        Else
            funcDirectory = ""
        End If
    End With
    funcDirectory = strDirectory
End Function

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...