28.11.2012

DAO - Accessdatenbank Anzahl aus allen Auswahlabfragen ausgeben...

Frage: In meinen Accessdatenbanken (.mdb und .accdb) habe ich einige Abfragen. Die Anzahl der Datensätze aller Auswahlabfragen möchte ich aus Excel herraus wissen. Wie geht das?

Hier noch eine Beispieldatei: DAO Accessdatenbank Anzahl aus allen Auswahlabfragen ausgeben...

Hinweis: Um diesen Code zu testen und das gleiche Ergebnis wie in der Beispieldatei zu erhalten werden die Beispieldatenbanken "nwind.mdb" und "nwind.accdb" von Microsoft benötigt!

Option Explicit
'----------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.11.2012 
' Purpose   : DAO Accessdatenbank Anzahl aus allen Auswahlabfragen ausgeben... 
'----------------------------------------------------------------------------- 
' Erstellt UND getestet in Excel 2010 - Access ist NICHT installiert 
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx 
Sub Main()
    ' Dimensionieren der Variablen 
    Dim objQueryDef As Object
    Dim objDBank As Object
    Dim objRSet As Object
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Hier öffne ich die Beispieldatenbank "Nwind.accdb" von Microsoft 
    ' Muss also noch aus dem Netz gezogen werden sofern nicht vorhanden 
    Set objDBank = CreateObject("DAO.DBEngine.120").OpenDatabase _
        ("C:\Temp\Nwind.accdb") ' Pfad- und Dateiname anpassen 
    ' http://msdn.microsoft.com/de-de/library/cc438676%28v=vs.71%29.aspx 
    ' Durchlaufe alle Abfragen 
    For Each objQueryDef In objDBank.QueryDefs
        ' Wenn die Abfrage NICHT mit einem "~" beginnt dann... 
        If Not Left(objQueryDef.Name, 1) = "~" Then
            ' Wenn die Abfrage eine Auswahlabfrage ist dann... 
            If objQueryDef.Type = 0 Then ' 240 = dbQAction, 0 = dbQSelect 
                ' Wenn die Abfrage keine Parameter erwartet dann... 
                If Not objQueryDef.Parameters.Count > 0 Then
                    ' Fülle die Objektvariable "objRSet" mit dem RecordSet 
                    Set objRSet = objDBank.QueryDefs _
                        (objQueryDef.Name).OpenRecordset()
                    With objRSet
                        .MoveLast
                        .MoveFirst
                    End With
                    ' Der Code bezieht sich auf ein bestimmtes Objekt 
                    ' Hier Tabelle1 = der CodeName der Tabelle 
                    ' Alles was sich auf dieses "With" bezieht 
                    ' MUSS mit einem Punkt beginnen 
                    With Tabelle1
                        ' Trage den Namen der Abfrage ein 
                        .Cells(lngRow + 1, 1).Value = objQueryDef.Name
                        ' Trage die Anzahl der Datensätze ein 
                        .Cells(lngRow + 1, 2).Value = objRSet.RecordCount
                    End With
                    lngRow = lngRow + 1
                    ' Setze die Objektvariable auf Nothing 
                    Set objRSet = Nothing
                End If
            End If
        End If
    Next objQueryDef
Fin:
    ' Schliesse die Datenbank 
    objDBank.Close
    ' Setze die Objektvariablen auf Nothing 
    Set objRSet = 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_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.11.2012 
' Purpose   : DAO Accessdatenbank Anzahl aus allen Auswahlabfragen ausgeben... 
'----------------------------------------------------------------------------- 
' Erstellt UND getestet in Excel 2010 - Access ist NICHT installiert 
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx 
Sub Main_1()
    ' Dimensionieren der Variablen 
    Dim objQueryDef As Object
    Dim objDBank As Object
    Dim objRSet As Object
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Hier öffne ich die Beispieldatenbank "Nwind.mdb" von Microsoft 
    ' Muss also noch aus dem Netz gezogen werden sofern nicht vorhanden 
    Set objDBank = CreateObject("DAO.DBEngine.36").OpenDatabase _
        ("C:\Temp\Nwind.mdb") ' Pfad- und Dateiname anpassen 
    ' http://msdn.microsoft.com/de-de/library/cc438676%28v=vs.71%29.aspx 
    ' Durchlaufe alle Abfragen 
    For Each objQueryDef In objDBank.QueryDefs
        ' Wenn die Abfrage NICHT mit einem "~" beginnt dann... 
        If Not Left(objQueryDef.Name, 1) = "~" Then
            ' Wenn die Abfrage eine Auswahlabfrage ist dann... 
            If objQueryDef.Type = 0 Then ' 240 = dbQAction, 0 = dbQSelect 
                ' Wenn die Abfrage keine Parameter erwartet dann... 
                If Not objQueryDef.Parameters.Count > 0 Then
                    ' Fülle die Objektvariable "objRSet" mit dem RecordSet 
                    Set objRSet = objDBank.QueryDefs _
                        (objQueryDef.Name).OpenRecordset()
                    With objRSet
                        .MoveLast
                        .MoveFirst
                    End With
                    ' Der Code bezieht sich auf ein bestimmtes Objekt 
                    ' Hier Tabelle1 = der CodeName der Tabelle 
                    ' Alles was sich auf dieses "With" bezieht 
                    ' MUSS mit einem Punkt beginnen 
                    With Tabelle1
                        ' Trage den Namen der Abfrage ein 
                        .Cells(lngRow + 1, 1).Value = objQueryDef.Name
                        ' Trage die Anzahl der Datensätze ein 
                        .Cells(lngRow + 1, 2).Value = objRSet.RecordCount
                    End With
                    lngRow = lngRow + 1
                    ' Setze die Objektvariable auf Nothing 
                    Set objRSet = Nothing
                End If
            End If
        End If
    Next objQueryDef
Fin:
    ' Schliesse die Datenbank 
    If Not objDBank Is Nothing Then objDBank.Close
    ' Setze die Objektvariablen auf Nothing 
    Set objRSet = 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

27.11.2012

Summe aus unbestimmter Anzahl Tabellenblätter...

Frage: Aus einer unbekannten Anzahl Tabellenblätter (die Anzahl kann auch mehr werden - die Startposition ist aber immer das dritte Tabellenblatt), soll die Summe aus Spalte C in einem Tabellenblatt "Auswertung" gezogen werden. Die Namen der Tabellenblätter sollen automatisch in Spalte A gelistet sein die Summen in Spalte B. Wie geht das?

Hier noch eine Beispieldatei: Summe aus unbestimmter Anzahl Tabellenblätter...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 27.11.2012 
' Purpose   : Summe aus unbestimmter Anzahl Tabellenblätter... 
'-------------------------------------------------------------------------- 
Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim lngLastRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Der Code bezieht sich auf ein bestimmtes Objekt 
    ' Hier Tabelle "Auswertung" 
    ' Alles was sich auf dieses "With" bezieht MUSS mit einem Punkt beginnen 
    With ThisWorkbook.Worksheets("Auswertung")
        ' lösche ab Zeile 2 abwärts den Inhalt raus 
        .Rows("2:" & .Rows.Count).ClearContents
        ' Alle Tabellenblätter in der Mappe mit dem Code 
        For Each wksSheet In ThisWorkbook.Worksheets
            ' Wenn die Tabelle am Index > 2 ist, dann... 
            If wksSheet.Index > 2 Then
                ' schreibe den Tabellenblattnamen der Tabellen AB Index 3 
                ' in Spalte A in die erste freie Zelle 
                .Range("A" & Rows.Count).End(xlUp) _
                    .Offset(1, 0).Value = wksSheet.Name
            End If
        Next wksSheet
        ' Bestimme jetzt die Anzahl der Zeilen in Spalte A 
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ' Trage nun in Spalte B ab Zeile 2 bis Ende Spalte A die Formel 
        ' =WENN(ISTFEHLER(SUMME(INDIREKT(A2&"!C:C"))); 
        ' "-";SUMME(INDIREKT(A2&"!C:C"))) ein 
        .Range("B2:B" & lngLastRow).Formula = _
            "=IF(ISERROR(SUM(INDIRECT(A2&""!C:C"")))," & _
            """-"",SUM(INDIRECT(A2&""!C:C"")))"
        ' Wandel die Formel in Werte um 
        .Range("B2:B" & lngLastRow).Value = .Range("B2:B" & lngLastRow).Value
    End With
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

23.11.2012

Aktuelles Datum finden - Ausgabe mehrerer Zellen...

Frage: In Spalte A in Tabelle 1 steht das Datum im Format z. B. "10.12.2012". In den Spalten B - D stehen dazugehörige Informationen. Nun soll das heutige Datum gesucht werden und die zugehörigen Informationen in einer MsgBox ausgegeben werden. Wie geht das?

Da es ja nicht unerhebliche Unterschiede in den Office / VBA Versionen gibt hier der Hinweis - erstellt und getestet in Excel 2010 / VBA7. Hier funktioniert das Suchen nach einem Datum (auch wenn es über eine Formel generiert wurde) wie unten gezeigt. In "älteren" Versioen muss gegebenenfalls angepasst werden (siehe Code).

Hier noch eine Beispieldatei: Aktuelles Datum finden - Ausgabe mehrerer Zellen...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Einzeln... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    Dim strTMP As String
    On Error GoTo Fin
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(Date, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                strTMP = strTMP & "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
            MsgBox strTMP
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Alle... 
'-------------------------------------------------------------------------- 
Sub Main_1()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    On Error GoTo Fin
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(Date, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                MsgBox "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Einzeln... 
'-------------------------------------------------------------------------- 
' Anpassung für ältere Office/VBA- Versionen 
Sub Main_2()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    Dim strTMP As String
    Dim dtmDate As Date
    On Error GoTo Fin
    dtmDate = Format(Date, "DD.MM.YYYY")
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(dtmDate, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                strTMP = strTMP & "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
            MsgBox strTMP
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

13.11.2012

Aktives Control in UserForm andere Farbe - API - Timer...

Frage: In meiner UserForm sind einige TextBoxen bzw. ComboBoxen. Die gerade aktive soll eine andere Farbe erhalten. CommandButton sollen die Farbe nicht ändern. Ich möchte nun nicht jedes Enter- bzw. Exitereignis einzeln für jedes Control angeben. Wie geht das?

Bemerkung: Über Klassen geht das nicht, da nicht alle Ereignisse zur Verfügung stehen (unter anderem auch das Enter- bzw. Exitereignis).

Hier noch eine Beispieldatei: Aktives Control in UserForm andere Farbe - API - Timer...

Code gehört in ein allgemeines Modul (Modul1):

Option Explicit
Option Private Module
Private Declare Function KillTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Const EXUSERFORM = "ThunderDFrame"
Private hWnd As Long
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : StartTimer 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 13.11.2012 
' Purpose   : Aktives Control in UserForm andere Farbe - API - Timer... 
'-------------------------------------------------------------------------- 
Public Sub StartTimer()
    hWnd = FindWindow(EXUSERFORM, UserForm1.Caption)
    SetTimer hWnd, 0&, 100&, AddressOf ControlTimer
End Sub
Sub StopTimer()
    KillTimer hWnd, 0&
End Sub
Private Sub ControlTimer(ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    On Error Resume Next
    Dim objControl As Control
    For Each objControl In UserForm1.Controls
        If TypeName(objControl) <> "CommandButton" Then
            objControl.BackColor = &H80FF80
        Else
            UserForm1.ActiveControl.BackColor = &H80000005
        End If
    Next objControl
End Sub

Code gehört in ein allgemeines Modul (Modul2):

Option Explicit
Public Sub Show_UF()
    UserForm1.Show 0
End Sub

Code gehört in das Modul der UserForm:

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : UserForm1 
' Procedure : UserForm_Activate 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 13.11.2012 
' Purpose   : Aktives Control in UserForm andere Farbe... 
'-------------------------------------------------------------------------- 
Private Sub UserForm_Activate()
    CommandButton1.TabStop = False
    Call StartTimer
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call StopTimer
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

08.11.2012

Parameter - Variable nach Word an ein Makro übergeben...

Frage: Immer wieder taucht die Frage auf, wie man Parameter bzw. eine Variable aus einem Makro in Excel an einen Code in einer Worddatei mitgeben kann, damit mit den Werten weitergerechnet bzw. Texte übernommen werden können.

Hier noch eine Beispieldatei: Parameter - Variable nach Word an ein Makro übergeben... - Zip-Datei mit der Excel- und Worddatei.

Hinweise, wie man Fenster in den Vordergrund holen kann:
Fenster in den Vordergrund...

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" _
    (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function AllowSetForegroundWindow Lib "user32.dll" _
    (ByVal dwProcessId As Long) As Long
Private Declare Function ShowWindow Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Const GC_CLASSNAMEWORD = "OpusApp"
Private Const SW_MAXIMIZE = 3
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 08.11.2012 
' Purpose   : Parameter / Variable nach Word übergeben... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim lngProcessID As Long
    Dim objApp As Object
    Dim strTMP As String
    Dim lngHwnd As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    lngTMP = Tabelle1.Range("A1").Value
    strTMP = Tabelle1.Range("B1").Value
    Set objApp = OffApp("Word")
    ' Folgende Zeile auskommentieren für Word NICHT sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        lngHwnd = FindWindow(GC_CLASSNAMEWORD, vbNullString)
        lngProcessID = GetWindowThreadProcessId(lngHwnd, ByVal 0&)
        Call AllowSetForegroundWindow(lngProcessID)
        Call SetForegroundWindow(lngHwnd)
        Call ShowWindow(lngHwnd, SW_MAXIMIZE)
        With objApp
            .Documents.Open ThisWorkbook.Path & _
                Application.PathSeparator & "Parameter.doc"
            .Run "Test", lngTMP, strTMP
    End With
    Else
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp 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

Code im Modul1 in der Worddatei:

Option Explicit
Sub Test(ByVal lngWert As Long, ByVal strTMP As String)
    MsgBox strTMP & " " & lngWert
End Sub

06.11.2012

Druckbereich als PDF - Alle und Einzeln...

Frage: In meiner Datei habe ich mehrere Tabellen mit Druckbereichen. Diese möchte ich alle in einer Datei haben. Erschwerend kommt hinzu, dass das Format (inklusive Zeilenhöhe) mit übernommen werden soll. Dann möchte ich die Druckbereiche noch jeweils in einer extra Datei. Wie geht das?

Hier noch eine Beispieldatei: Druckbereich als PDF - Alle und Einzeln... Dies ist eine "XLSB-Datei" - also mit rechter Maustaste anklicken und dann "Ziel speichern unter..." wählen.

Weitere Stolperfallen:
Auch noch zu beachten...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF... 
'-------------------------------------------------------------------------- 
Sub Main()
Dim wkbBook As Workbook
    Dim varSheet As Variant
    Dim intTMP As Integer
    Dim blnTMP As Boolean
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=UBound(varSheet)
    End With
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            If .PageSetup.Orientation = 2 Then blnTMP = True
            If .PageSetup.PrintArea <> "" Then
                .Range(.PageSetup.PrintArea).Copy
            End If
        End With
        With wkbBook.Worksheets(intTMP + 1)
            .Range("A1").PasteSpecial 8
            .Range("A1").PasteSpecial -4163
            .Range("A1").PasteSpecial -4122
            If blnTMP = True Then
                .PageSetup.Orientation = 2
                blnTMP = False
            End If
            Application.Goto .Range("A1")
        End With
        With Application
            .Goto wkbBook.Worksheets(1).Range("A1"), True
            .CutCopyMode = True
        End With
    Next intTMP
    Application.Goto wkbBook.Worksheets(1).Range("A1"), True
    wkbBook.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & _
        ThisWorkbook.Name, , , , , , True
    wkbBook.Close False
Fin:
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF - mit Zeilenhöhe... 
'-------------------------------------------------------------------------- 
Sub Main_1()
Dim wkbBook As Workbook
    Dim varSheet As Variant
    Dim rngRange As Range
    Dim intTMP As Integer
    Dim blnTMP As Boolean
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=UBound(varSheet)
    End With
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            If .PageSetup.Orientation = 2 Then blnTMP = True
            If .PageSetup.PrintArea <> "" Then
                Set rngRange = .Range(.PageSetup.PrintArea)
                .Rows("1:" & rngRange.Rows.Count).Copy _
                    wkbBook.Worksheets(intTMP + 1).Cells
                 wkbBook.Worksheets(intTMP + 1).UsedRange.ClearContents
                .Range(.PageSetup.PrintArea).SpecialCells(12).Copy
            End If
        End With
        With wkbBook.Worksheets(intTMP + 1)
            .Range("A1").PasteSpecial 8
            .Range("A1").PasteSpecial -4163
            .Range("A1").PasteSpecial -4122
            If blnTMP = True Then
                .PageSetup.Orientation = 2
                blnTMP = False
            End If
            Application.Goto .Range("A1")
        End With
        With Application
            .Goto wkbBook.Worksheets(1).Range("A1"), True
            .CutCopyMode = True
        End With
    Next intTMP
    Application.Goto wkbBook.Worksheets(1).Range("A1"), True
    wkbBook.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & _
        ThisWorkbook.Name, , , , , , True
    wkbBook.Close False
Fin:
    Set rngRange = Nothing
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul3 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF - jeder Druckbereich extra Datei... 
'-------------------------------------------------------------------------- 
Sub Main_2()
    Dim varSheet As Variant
    Dim intTMP As Integer
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            .Range(.PageSetup.PrintArea).ExportAsFixedFormat 0, _
                ThisWorkbook.Path & "\" & .Name
        End With
    Next intTMP
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Eingabe einsortieren...

Frage: In Spalte A gebe ich Namen ein. Diese sollen sofort bei der Eingabe alphabetisch sortiert werden. Dann soll diese Eingabe ausgewählt und die Spaltebnbreite wieder automatisch angepasst werden. Wie geht das?

Hier noch eine Beispieldatei: Eingabe einsortieren...

Code gehört in den Codebereich des entsprechenden Tabellenblattes:
Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Tabelle1 
' Procedure : Worksheet_Change 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Eingabe einsortieren - zu Eingabe springen... 
'-------------------------------------------------------------------------- 
Public Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fin
    If Not Target.Count > 1 Then
        If Target.Column = 1 And Cells(Target.Row, Target.Column) <> "" Then
            Call Sortieren(Me, Target.Value)
        End If
    End If
    Me.Columns("A").AutoFit
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in ein allgemeines Modul:
Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Sortieren 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Eingabe einsortieren - zu Eingabe springen... 
'-------------------------------------------------------------------------- 
Sub Sortieren(ByVal wksSheet As Worksheet, ByVal strTMP As String)
    Dim varTMP As Variant
    On Error GoTo Fin
    With wksSheet
        .Range("A1").Sort Key1:=.Range("A1"), Header:=xlGuess
        varTMP = Application.Match(strTMP, .Columns(1), 0)
        If Not IsError(varTMP) Then
            Application.Goto .Cells(varTMP, 1)
        End If
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

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 ...