April 2017

Der VBA-Kracher – April 2017

F√ľr die ¬†April ‚Äď Ausgabe haben wir uns die folgenden Themen √ľberlegt.

  • Automatische Sicherung von E-Mails in einer Access-Datenbank
  • Eine Durchschnitts-Ermittlung aus den Top-5-Werten berechnen
  • Automatische Erstellung von Arbeitsmappen
  • Alle Formeln einer Tabelle sch√ľtzen und verstecken
  • Eine Unikatsliste √ľber den Einsatz von SQL erstellen

Automatische Sicherung von e-Mails in einer Access-Datenbank

Im ersten Beispiel stelle ich Ihnen eine L√∂sung vor, die ich vor einiger Zeit entwickelt habe und die es mir erlaubt, meine e-Mails in einer Access-Datenbank zu speichern. Warum ich das brauche? Nun, mein Postfach hat die Angewohnheit, immer wieder voll zu laufen. Als Soforthilfe l√∂sche ich dann immer wieder alte e-Mails, um schnell wieder erreichbar zu sein. Bl√∂d nur, wenn man diese gel√∂schten e-Mails dann irgendwann einmal wieder braucht. Es gibt zwar eine Archivfunktion in Outlook, die f√ľr mich aber nicht das gew√ľnschte Ergebnis lieferte und f√ľr mein Empfinden doch etwas langsam ist. Daher legte ich zun√§chst eine Access-Tabelle nach dem folgenden Vorbild an.

Danach werden die Bibliotheken Microsoft Outlook und Microsoft ActiveX Daten Objects unter dem Men√ľ Extras und dem Befehl Verweise eingebunden.

Das Makro, welches diese Aufgabe erledigt sieht dabei wie folgt aus:

Sub EMailsSichern()
  Dim objOutFold As Outlook.MAPIFolder
  Dim lngGes As Long, lngZZ As Long
  Dim conn As New ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim dteMAx As Date, lngAnz As Long

 On Error GoTo Fehler
 Set conn = CurrentProject.Connection
 Set rst = New ADODB.Recordset
 rst.Open "MailIN", conn, adOpenKeyset, adLockOptimistic

Set objOutFold = GetObject("", "Outlook.Application").GetNamespace _
        ("MAPI").GetDefaultFolder(olFolderInbox)
   dteMAx = DMax("Erhalten", "MailIN")
   lngGes = objOutFold.Items.Count
   lngZZ = 0

    For lngZZ = 1 To lngGes      

            With objOutFold.Items(lngZZ)
              If .ReceivedTime > dteMAx Then
              lngAnz = lngAnz + 1
                rst.AddNew
                rst!Titel = .Subject
                rst!Absender = .SenderName
                rst!Inhalt = .Body
                rst!Erhalten = Format _
                (.ReceivedTime, "dd.mm.yyyy hh:mm")
                rst!Anhang = .Attachments.Count
                rst!Größe = .Size
                If Not .UnRead = -1 Then
                    rst!Gelesen = "Ja"
                Else
                    rst!Gelesen = "Nein"
                End If               
                rst.Update
              End If
            End With
    Next lngZZ
    rst.Close
    With rst
        .CursorLocation = adUseClient
        .Open "MailIN", conn, adOpenKeyset, adLockOptimistic
        .Sort = "Erhalten ASC"
    End With

    Set objOutFold = Nothing
    Set rst = Nothing
    Set conn = Nothing

    MsgBox "Fertig! Es wurden " & lngAnz & _
     " neue Mails gespeichert!"
    Exit Sub

Fehler:
    MsgBox Err.Number & " " & Err.Description

End Sub

Quelle:VBA-Tanker, ID8818

√Ėffnen Sie mit Hilfe der Methode Open die Access-Datentabelle MailIn. Danach greifen Sie auf Ihr ge√∂ffnetes Outlook √ľber die Anweisung GetObject zu. Mit Hilfe der Eigenschaft GetDefaultFolder und der Konstanten olFolderInbox haben Sie danach Zugriff auf Ihren Standard Outlook-Posteingangskorb. √úber die Funktion DMax ermitteln Sie das zuletzt in der Datenbank abgelegte E-Mail. Dies soll verhindern, dass e-Mails doppelt abgelegt werden. Danach ermitteln Sie die Gesamtanzahl der im Posteingang befindlichen e-Mails mit Hilfe der Funktion Count. In einer anschlie√üenden For Next Schleife arbeiten Sie alle e-Mails nacheinander ab. Innerhalb der Schleife wird anhand des Eingangsdatums gepr√ľft, ob das gerade verarbeitete E-Mail bereits eingespielt wurde. Wenn nicht, dann wenden Sie die Methode AddNew an, um einen zun√§chst leeren, neuen Eintrag in der Datenbank anzulegen. F√ľllen Sie danach die Felder wie beispielsweise den Titel und den Absendernamen, indem Sie die Eigenschaften Subject und SenderName abfragen. Komplettieren Sie die restlichen Felder und nutzen Sie die Methode Update, um den neuen Datensatz in der Tabelle zu speichern.

√Ėffnen Sie nach dem Import der neuen e-Mails noch einmal die Datentabelle und wenden die Methode Sort an, um die Tabelle so zu sortieren, dass die neuesten e-Mails zu Beginn der Tabelle angezeigt werden.

Eine Durchschnitts-Ermittlung aus den Top-5-Werten berechnen

Bei der folgenden Aufgabenstellung soll in einem Datenbereich ein Durchschnitt aus den 5 höchsten Werten gebildet werden. Sehen Sie sich dazu einmal die Ursprungstabelle in der folgenden Abbildung an:

 

 

 

 

 

 

 

 

 

 

 

Das Makro f√ľr diese Aufgabe entnehmen Sie dem folgenden Listing.

Sub Top5AvgInBereichFinden()
    Dim sngWert1 As Single, sngWert2 As Single
    Dim sngWert3 As Single, sngWert4 As Single
    Dim sngWert5 As Single
    Dim rngBereich As Range
    Dim rngzelle As Range

    Set rngBereich = Tabelle1.Range("A1:D10")
    sngWert1 = Application.WorksheetFunction.Large(rngBereich, 1)
    sngWert2 = Application.WorksheetFunction.Large(rngBereich, 2)
    sngWert3 = Application.WorksheetFunction.Large(rngBereich, 3)
    sngWert4 = Application.WorksheetFunction.Large(rngBereich, 4)
    sngWert5 = Application.WorksheetFunction.Large(rngBereich, 5)

    rngBereich.Interior.ColorIndex = xlColorIndexNone   
    For Each rngzelle In rngBereich
     If rngzelle.Value >= sngWert5 Then
        rngzelle.Interior.ColorIndex = 4
     End If
    Next rngzelle
    Tabelle1.Range("K1").Value = _
    Application.WorksheetFunction.Average _
    (sngWert1, sngWert2, sngWert3, sngWert4, sngWert5)

End Sub

Quelle: VBA-Tanker, ID195

Geben Sie im ersten Schritt des Makros bekannt, auf welcher Tabelle sich der zu durchsuchende Bereich befindet und wie gro√ü dieser Bereich ist. Speichern Sie diese Information in der Bereichsvariablen rngBereich mit Hilfe der Anweisung Set. Mit Hilfe der WorksheetFunktion Large greifen Sie auf die Tabellenfunktion KGR√ĖSSTE zu, √ľber die Sie n-H√∂chstwerte aus einem Bereich ermitteln k√∂nnen. Diese Werte sollen anschlie√üend in dem vorher angegebenen Bereich gefunden und eingef√§rbt werden. In einer anschlie√üenden For Each Next-Schleife wird nun Zelle f√ľr Zelle dieses Bereichs durchlaufen. Innerhalb der Schleife findet ein Vergleich statt. Alle Werte, die gr√∂√üer oder gleich dem f√ľnftgr√∂√üten Wert sind, werden dabei mit Hilfe der Eigenschaft ColorIndex und dem Objekt Interior eingef√§rbt. Ermitteln Sie nach Schleifenaustritt den Durchschnitt dieser 5 H√∂chstwerte, indem Sie die Worksheetfunction Average aufrufen und dieser Funktion die Variablen sngWert1 bis sngWert5 √ľbergeben.

Tipp:

Ein kleiner Zusatz noch: Wie viele Zeilen Quellcode braucht mach, um den größten Wert in dem gerade angegebenen Bereich zu finden und automatisch zu markieren?

Genau eine einzige Zeile

 Range("A1:D10").Find(Application.Max(Range("A1:D10"))).Select

Automatische Erstellung von Arbeitsmappen auf Knopfdruck

Das Kopieren einzelner Tabellen sowie die Speicherung dieser Tabellen als einzelne Arbeitsmappen ist eine lästige und langwierige Aufgabe. Stellen Sie sich einmal vor, Sie haben die Aufgabe aus einer Arbeitsmappe mit 30 Kostenstellentabellen genau 50 Arbeitsmappen zu erstellen, wo-bei jede einzelne Tabelle als separate Datei abzulegen ist. Die 50 Kopier- und Speichervorgänge brauchen schon einiges an Zeit.

Wie w√§re es da ein Makro zu schreiben, was diese Angelegenheit in weniger als 5 Sekunden f√ľr Sie erledigt?

Als Ausgangssituation liegt eine Arbeitsmappe mit genau 50 Tabellen vor. Speichern Sie diese 50 Tabellen einzeln in Arbeitsmappen mit folgendem Makro:

Sub TabellenAlsMappenAblegen()
  Dim wksBlatt As Worksheet
  Dim wkbZiel As Workbook
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wksBlatt In ThisWorkbook.Worksheets

    If wksBlatt .Visible = xlSheetVisible Then

       wksBlatt.Copy
       Set wkbZiel = ActiveWorkbook

       wkbZiel .SaveAs ThisWorkbook.Path & "/" & _
        wksBlatt .Name & ".xlsx"

       wkbZiel .Close

    End If 

  Next wksBlatt

 Application.DisplayAlerts = True  
 Application.ScreenUpdating = True

End Sub

Deklarieren Sie zu Beginn des Makro je eine Objektvariable vom Typ Worksheet sowie vom Typ Workbook. Schalten Sie danach die Bildschirmaktualisierung tempor√§r ab, indem Sie der Eigenschaft ScreenUpdating den Wert False zuweisen. Mit Hilfe der Eigenschaft DisplayAlerts k√∂nnen Sie Warnmeldungen von Excel tempor√§r abschalten. Dies ist dann zum Beispiel der Fall, wenn Sie das Makro mehrere Male hintereinander laufen lassen. In diesem Fall werden die ‚Äěalt‚Äú erstellten Mappen automatisch mit den neuen Mappen ersetzt.
Verarbeiten Sie danach in einer For Each Next-Schleife alle sich in der Arbeitsmappe befindliche Tabellen. Innerhalb der Schleife pr√ľfen Sie mit Hilfe der Eigenschaft Visible, ob die jeweilige Tabelle sichtbar ist. Wenn ja, dann wenden Sie die Methode Copy ohne weitere Parameter an, um die Tabelle automatisch in eine neue Mappe einzuf√ľgen. Speichern Sie diese im Anschluss daran, indem Sie die Methode SaveAs einsetzen. √úber die Eigenschaft Path k√∂nnen Sie dabei auf den Ordner zugreifen, indem auch dieses Makro gespeichert ist. Demnach werden alle neuen Mappen im gleichen Verzeichnis abgelegt. Nach der Speicherung der jeweiligen Mappe wird die Methode Close eingesetzt, um die gerade erstellt Mappe zu schlie√üen.

Alle Formeln einer Tabelle sch√ľtzen und verstecken

Angenommen, Sie haben eine Tabelle entworfen, auf der der Anwender Eingaben machen soll, mit denen in Formelzellen weitergerechnet wird. Sie m√∂chten Ihre Formeln zum einen vor Manipulation, zum anderen auch vor neugierigen Blicken sch√ľtzen.

Manuell haben Sie zwei M√∂glichkeiten, das zu bewerkstelligen: Sie markieren erst alle Zellen und stellen im Zellformat ‚Äěgesch√ľtzt‚Äú und ‚Äěausgeblendet‚Äú ein und nehmen danach f√ľr alle Zellen, in denen Eingaben gemacht werden d√ľrfen wieder heraus. Oder Sie machen diese Einstellungen nur f√ľr die einzelnen Formelzellen. Vorher m√ľssen Sie nat√ľrlich noch den Blattschutz entfernen, wenn einer gesetzt ist und danach wieder aktivieren. Ein riesiger Aufwand, vor allem, wenn man das f√ľr mehrere Tabellen machen muss und dann auch noch immer wieder das Passwort eingeben muss.

Diese Makro setzt die zweite Variante um ‚Äď und zwar f√ľr alle Tabellen der aktiven Arbeitsmappe. Es verwendet ein Passwort, das Sie entweder durch ein eigenes ersetzen oder komplett l√∂schen k√∂nnen.

Sub FormelnSchuetzenUndVerstecken()
    Dim wksBlatt As Worksheet
    Dim rngZelle As Range

    For Each wksBlatt In ActiveWorkbook.Worksheets

        wksBlatt.Unprotect "DasPasswort"
        wksBlatt.UsedRange.Locked = False
        wksBlatt.UsedRange.FormulaHidden = False

        For Each rngZelle In wksBlatt.UsedRange

            If rngZelle.HasFormula Then
                rngZelle.Locked = True
                rngZelle.FormulaHidden = True
            End If

        Next rngZelle

        wksBlatt.Protect "DasPasswort"

    Next wksBlatt  

End Sub

Mit Hilfe einer For Each Next ‚Äď Schleife werden alle Tabellen nacheinander in der Mappe durchlaufen. Innerhalb der Schleife kommt die Methode Unprotect zum Einsatz, um den vorher eingestellten Tabellenschutz aufzuheben. Danach werden alle Zellen im benutzten Bereich der Tabelle √ľber die Eigenschaft Locked als editierbar gekennzeichnet und √ľber die Eigenschaft FormulaHidden formeltechnisch sichtbar gemacht. In einer anschlie√üenden inneren Schleife werden alle Zellen in der aktuellen Tabelle verarbeitet. Innerhalb dieser Schleife wird mittels der Eigenschaft HasFormula gepr√ľft, ob die Zelle eine Formel enth√§lt. Wenn ja, dann weisen Sie den Eigenschaften Locked und FormulaHidden den Wert True zu, um die Zelle zu sch√ľtzen und die Formel darin auszublenden. Diese Einstellungen werden erst dann wirksam, wenn Sie die jeweilige Tabelle mit Hilfe der Methode Protect sch√ľtzen.

Eine Unikatsliste √ľber den Einsatz von SQL erstellen

Bei der letzten Aufgabenstellung soll aus einer Tabelle, in der Daten redundant gespeichert sind, eine Unikatsliste erzeugt werden. Schauen Sie sich vorab einmal die Ausgangssituation in der folgenden Abbildung an.

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

Auf Basis des Lieferanten soll eine Liste erzeugt werden, in der jeder Lieferant nur einmal vorkommt. Diese Aufgabe k√∂nnen Sie beispielsweise √ľber folgendes Makro l√∂sen:

Sub UnikatsListePerSQL()
'Vorher die Bibliothek Microsoft ActiveX Data Objects einbinden
  Dim ADOConn As New ADODB.Connection
  Dim rst As New ADODB.Recordset
  Dim strSQL As String, strBereich As String
  Dim rngBereich As Range, rngZiel As Range
 
  With tbl_Daten

    .Range("H:H").Clear
    Set rngBereich = Range("B2:B" & .UsedRange.Rows.Count)
    .Range("H1").Value = "Lieferant"
    Set rngZiel = .Range("H2")
    ADOConn.Open _
    "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & _
    ThisWorkbook.FullName
    strBereich = rngBereich.Address _
    (RowAbsolute:=False, ColumnAbsolute:=False)
    strSQL = "SELECT DISTINCT * FROM [tbl_Daten$" & strBereich & "]"
    rst.Open strSQL, ADOConn, adOpenKeyset, adLockOptimistic
    rngZiel.CopyFromRecordset rst   
    rst.Close
    Set rst = Nothing
  End With

End Sub
Quelle: VBA-Tanker, ID5553

In Spalte H der Tabelle tbl_Daten soll die Unikatliste eingef√ľgt werden. Sicherheitshalber leeren sie diese Spalte, indem Sie die Methode Clear einsetzen. Geben Sie danach √ľber die Anweisung Set bekannt, wo sich der Bereich befindet, aus dem Sie die Unikatsliste erstellen m√∂chten. √úbergeben Sie danach den Namen sowie den Pfad der aktuell ge√∂ffneten Arbeitsmappe am die Methode Open. Formulieren Sie das SQL-Statement, indem Sie die Schl√ľsselbegriffe SELECT DISTINCT verwenden, um keine doppelten Daten zu erstellen. Greifen Sie auf die Tabelle sowie den zuvor gebildeten Bereich zu und¬† erstellen daraus ein RecordsetObject. Die unikaten Daten liegen jetzt alle in diesem Objekt. Mit Hilfe der Methode CopyFromRecordset k√∂nnen Sie den Inhalt dieses Objekts direkt beginnend ab der Zielzelle H2 ausleeren.¬† Schlie√üen Sie im Anschluss das RecordSet-Objekt mit Hilfe der Anweisung Close. Und entfernen Sie die Variable aus dem Speicher, indem Sie der Variablen rst den Wert Nothing zuweisen.