November 2017

VBA-Kracher November 2017

Am 14.11-15.11 fanden die 6. VBA-Entwicklertage in Walting statt. Die Veranstaltung war bis zum letzten Platz belegt und wir haben viele sehr interessante Vorträge gehört.  In diesem Newsletter möchte ich gerne Inhalte aus den Entwicklertagen aufgreifen und zum Teil weiterentwickeln.

Im November-VBA-Kracher Newsletter werden die folgenden Themen behandelt:

  • Termine in Outlook automatisch anlegen
  • Daten konsolidieren √ľber SQL / ADO
  • Eine Tabelle auf mehrere Tabellen verteilen (ADO)
  • Formeln/Verkn√ľpfungen in einer Tabelle finden

Termine in Outlook automatisch anlegen

Beim Vortrag von Dominik Petri zum oben genannten Thema wurden aus einer Excel-Tabelle einige Termine automatisch in den Outlook-Kalender gespielt. Bei dieser Pr√§sentation wie im √ľbrigen bei allen Pr√§sentationen wurde viel diskutiert und gefachsimpelt. Es entstanden somit neue Anregungen und Ideen. Unter anderem wurde gefragt, ob Outlook kontrolliert, wenn Termine angelegt werden, ob diese nicht bereits im Kalender angelegt sind. Die Frage konnte mit einem eindeutigen Nein beantwortet werden. Das bedeutet, dass Termine doppelt angelegt werden, wenn das Anlage-Makro doppelt ausgef√ľhrt wird. ¬†Danach kam die Diskussion auf, wie man wohl Termine in Outlook verarbeiten kann. Eine Methode w√§re eben, alle Termine mittels einer Schleife zu durchlaufen und zu diese zu l√∂schen. Dazu m√ľssten sich die Termine aber von anderen Terminen unterscheiden. Alternativ k√∂nnte man die so automatisch angelegten Termine in eine bestimmte Kategorie schieben und entsprechend dann pr√ľfen. In beiden F√§llen w√ľrden jedoch alle Termine in Outlook nacheinander verarbeitet werden, was nat√ľrlich ein Laufzeit-Problem ist. Daher gibt es mindestens zwei Ans√§tze, um diese Aufgabenstellung auf eine andere Art zu l√∂sen:

  • Eingrenzen des zu durchsuchenden Terminbereichs oder
  • Beim Anlegen eines Termins die EntryID protokollieren und den Termin √ľber diese ID finden

Exemplarisch habe ich eine kleine Tabelle mit Terminen angelegt und ein Makro zur automatischen Anlage von Terminen geschrieben. Die beiden vorgeschlagenen Techniken zur Löschung der Termine finden Sie im weiteren Verlauf dieses Newsletters.


In einer Tabelle werden das Datum sowie der Titel einer Veranstaltung ausgegeben. Das nachfolgende Makro legt diese Termine in Outlook an und f√ľllt danach die Spalte C der Tabelle mit dem eindeutigen EntryID des Termins.

Sub TermineVonExcelNachOutlookTransferieren()
'Vorher die Outlook Bibliothek unter Extras/Verweise aktivieren
    Dim outl As New Outlook.Application
    Dim Termin As Object
    Dim lngZeile As Long
    Dim lngZeileMax As Long

    lngZeileMax = Tabelle1.Range("A" & _
     Tabelle1.Rows.Count).End(xlUp).Row

  For lngZeile = 2 To lngZeileMax

    Set Termin = outl.CreateItem(olAppointmentItem)
        With Termin
            .Subject = "[" & Tabelle1.Cells(lngZeile, 2).Value & "]"
            .Start = CDate(Tabelle1.Cells(lngZeile, 1).Value)
            .AllDayEvent = True
            .ReminderSet = False
            .Categories = "Schulungen"
            .Save
            Tabelle1.Range("C" & lngZeile).Value = .EntryID
        End With
    Next lngZeile
    MsgBox "Es wurden " & lngZeile - 2 & _
 ¬†¬† " Termine in den Kalender von Outlook √ľbertragen!"
    Set Termin = Nothing
    Set outl = Nothing
End Sub
 
 '*** Quelle: VBA-Tanker, ID 9029

Mit Hilfe der Methode CreateItem und der Konstante olAppointmentItem kann ein Termin im Outlook Kalender angelegt werden. Über die Eigenschaft Subject wird dem Termin ein Titel aus der Spalte B der Tabelle1 zuwiesen. Der Tagestermin wird mittels der Eigenschaft Start zugewiesen. Über die Eigenschaft Categories kann der Termin einer Kategorie zugewiesen werden.  Mit der Methode Save wird der Termin gespeichert. Dadurch wird eine EntryID gebildet, die Sie in der Tabelle in Spalte C festhalten.

Sollen jetzt die gerade angelegten Termine wieder aus dem Outlook-Kalender entfernt werden, dann wird das folgende Makro gestartet:

Sub OutlookKalenderBereinigenEntryID()
    Dim appOutlook As Outlook.Application
    Dim objOutTermin As Object
    Dim nspOutlookNameSpace As Outlook.Namespace
    Dim lngZeileMax As Long
    Dim lngZeile As Long

      Set appOutlook = New Outlook.Application
      Set nspOutlookNameSpace = appOutlook.GetNamespace("MAPI") 

    With Tabelle1
      lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
      On Error GoTo fehlerbehandlung
      For lngZeile = 2 To lngZeileMax
      Set objOutTermin = _
       nspOutlookNameSpace.GetItemFromID(.Range("C" & _
       lngZeile).Value)    
      objOutTermin.Delete     
      Next lngZeile
    End With
Exit Sub

fehlerbehandlung:
MsgBox Err.Description
End Sub
 
 '*** Quelle: VBA-Tanker, ID 9029

Mit Hilfe der Eigenschaft GetItemFormID kann mit Hilfe der EntryId ein Termin gefunden werden. Wir der Termin gefunden, dann wird die Methode Delete angewendet, um den Eintrag zu entfernen.¬†Bei der anderen Alternative w√ľrden die Termine im Kalender eingegrenzt. In diesem Fall m√ľsste dann der Kalender nicht komplett, sondern eben gefiltert durchsucht werden.

Sub OutlookKalenderBereinigen()
    Dim appOutlook As Outlook.Application
    Dim folAppointment As Outlook.MAPIFolder
    Dim itmAppointments As Outlook.Items
    Dim nspOutlookNameSpace As Outlook.Namespace
    Dim objOutTermin As Outlook.AppointmentItem
    Dim objOutTermine As Object
    Dim lngZeileMax As Long
    Dim lngZeile As Long

      Set appOutlook = New Outlook.Application
      Set nspOutlookNameSpace = appOutlook.GetNamespace("MAPI")
      Set folAppointment = _
       nspOutlookNameSpace.GetDefaultFolder(olFolderCalendar)   

    With Tabelle1
      lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
      For lngZeile = 2 To lngZeileMax    
      Set objOutTermine = _
       folAppointment.Items.Restrict("[Start] >= '" & _
     Format(.Cells(lngZeile, 1).Value - 1, "mm""/""dd""/""yyyy") 
      "' and  [Start] <= '" & Format(.Cells(lngZeile, 1).Value,  
        "mm""/""dd""/""yyyy") & "'")
        For Each objOutTermin In objOutTermine
         If Left(objOutTermin.Subject, 1) = "[" Then
          objOutTermin.Delete
         End If
        Next objOutTermin  
      Next lngZeile
    End With
End Sub

'*** Quelle: VBA-Tanker, ID 9027

Mit Hilfe der Methode Restrict kann ein Filter auf den Kalender angewendet werden. Dieser Filter wird anhand des Datums aus der Spalte A der Tabelle gebildet.

Daten konsolidieren √ľber SQL & ADO

Bei der folgenden Aufgabenstellung aus meinem Vortrag ‚ÄěMassendaten gekonnt konsolidieren mit VBA‚Äú¬† ging es um die Aufgabenstellung wie man m√∂glichst schnell 500.000 Datens√§tze aus einer Tabelle in eine Berichtsmatrix spielen kann.

 

 

 

 

 

 

 

 

 

 

 

Das Makro zur Lösung dieser Aufgabenstellung sieht dabei wie folgt aus:

Sub DatenVerdichten02()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String

tbl_Ergebnis.Range("DatenErg").ClearContents
Application.ScreenUpdating = False
Set cn = CreateObject("ADODB.CONNECTION")
'Den Treiber bekanntgeben
strConnection = _
"DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName
With cn
'Datenverbindung öffnen
.Open strConnection
'Abfragestring zusammenbasteln und Abfrage starten
strSQL = "SELECT Kostenstelle, Monat, Sum(Umsatz) AS Summe1 " & _
"FROM [tbl_Daten$] GROUP BY Kostenstelle, Monat ORDER BY
 Kostenstelle, Monat"

Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.Open
tbl_Temp.Range("A1").CopyFromRecordset rs
.Close
End With
End With

'ADO-Verbindung kappen
cn.Close

Set cn = Nothing
Set rs = Nothing

With tbl_Temp
For Each rngZelle In tbl_Ergebnis.Range("DatenErg")
rngZelle.Value = _
 Application.WorksheetFunction.SumIfs(.Range("C:C"), _
.Range("A:A"), tbl_Ergebnis.Cells(rngZelle.Row, 1).Value, _
.Range("B:B"), tbl_Ergebnis.Cells(1, rngZelle.Column).Value)
Next rngZelle
End With
Application.ScreenUpdating = True
End Sub

'*** Quelle: VBA-Tanker, ID 8329

Der Zugriff auf die Datentabelle findet √ľber die Zugriffsmethode ADO und einer SQL-Anweisung statt. Diese Anweisung erzeugt f√ľr jeden Monat und f√ľr jede Kostenstelle genau eine Summe. Diese Summen werden in einer Zwischentabelle in einem Aufwasch √ľber die Methode CopyFromRecordset abgelegt. Danach wird der benannte Ergebnisbereich der Tabelle tbl_Ergebnis Zelle f√ľr Zelle abgearbeitet. Innerhalb der Schleife wird mittels der Funktion SUMIFS eine bedingte Summierung durchgef√ľhrt und das Ergebnis f√ľr die Zielzelle berechnet.

Eine Tabelle auf mehrere Tabellen verteilen (ADO)

Bei der folgenden Aufgabenstellung liegt eine Tabelle mit Daten vor, die auf andere dynamisch zu erzeugende Tabellen verteilt werden soll.

F√ľr jede Kostenstelle soll eine eigene Tabelle erzeugt werden.¬† Die Makros daf√ľr lautet wie folgt:

Sub DatenVerteilen()
Call TabellenEntfernen
Call UnikatslisteErstellen
Call SQLAbfrageExcelTabelleMitBedingungLateBinding
End Sub

Sub TabellenEntfernen()
Dim wksBlatt As Worksheet

Application.DisplayAlerts = False
For Each wksBlatt In ThisWorkbook.Worksheets
Select Case wksBlatt.CodeName
Case "tbl_Daten", "tbl_Unikatsliste"
'keine Aktion
Case Else
wksBlatt.Delete
End Select
Next wksBlatt
Application.DisplayAlerts = True
End Sub

Sub UnikatslisteErstellen()
With tbl_Daten
tbl_Unikatsliste.Range("A:A").ClearContents
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
copyToRange:=tbl_Unikatsliste.Range("A1"), unique:=True
End With
End Sub


Sub SQLAbfrageExcelTabelleMitBedingungLateBinding()
Dim cn As Object
Dim rs As Object
Dim lngZeile As Long
Dim strFile As String
Dim strCon As String
Dim lngZeileMax As Long
Dim wksZiel As Worksheet

strFile = ThisWorkbook.FullName

strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
 strFile  & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon

With tbl_Unikatsliste
lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
For lngZeile = 2 To lngZeileMax
 Set wksZiel = _
 Worksheets.Add(after:=Worksheets(Worksheets.Count))
 wksZiel.Name = .Range("A" & lngZeile).Value
 wksZiel.Rows(1).Value = tbl_Daten.Rows(1).Value
 'strSQL = "SELECT * FROM [tbl_Daten$] WHERE Kostenstelle ='" & _
 .Cells(lngZeile, 1).Text & "'"¬† 'f√ľr Texte
 strSQL = "SELECT * FROM [tbl_Daten$] WHERE Kostenstelle = " & _
 .Cells(lngZeile, 1).Text¬†¬†¬†¬†¬†¬†¬†¬† 'f√ľr Zahlen
 rs.Open strSQL, cn
 wksZiel.Range("A2").CopyFromRecordset rs
 rs.Close
Next lngZeile
cn.Close
End With
End Sub

'*** Quelle: VBA-Tanker, ID 8676

Im ersten Makro werden zun√§chst alle Kostenstellen-Tabellen aus der Arbeitsmappe entfernt. Dazu wird eine For Each Next-Schleife eingesetzt. In der Schleife wird gepr√ľft, ob die jeweilige Tabelle gel√∂scht werden darf. Wenn ja, dann wird die Methode Delete eingesetzt, um die Tabelle zu entfernen.

Im zweiten Makro wird die Methode AdvancedFilter eingesetzt, um eine Unikatsliste mit Kostenstellen zu erstellen. Diese werden dann dynamisch im dritten Makro erstellt. Dazu wird der Recordset mittels einer SQL-Anweisung gef√ľllt und mit Hilfe der Methode CopyFromRecordset direkt in die jeweilige Zieltabelle geschrieben.

Formeln/Verkn√ľpfungen in einer Tabelle finden

Bei der letzten Aufgabenstellung sollen alle Formen und Verkn√ľpfungen zu anderen Tabellen und Arbeitsmappen in einer Tabelle gefunden und automatisch gekennzeichnet werden.

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


For Each wksBlatt In ThisWorkbook.Worksheets

For Each rngZelle In wksBlatt.UsedRange

 If rngZelle.HasFormula = True Then
   If InStr(rngZelle.Formula, "!") > 0 Then
      rngZelle.Interior.ColorIndex = 24
   Else
   rngZelle.Interior.ColorIndex = 15
   End If
 End If
 Next rngZelle

Next wksBlatt

End Sub

'*** Quelle: VBA-Tanker, ID 7203

In einer For Each Next-Schleife werden alle Tabellen der Arbeitsmappe abgegrast. In der zweiten geschachtelten Schleife werden alle Zellen im benutzten Bereich abgearbeitet und¬† √ľber die Eigenschaft HasFormula gepr√ľft, ob die jeweilige Zelle eine Formel hat. Wenn ja, dann kann es sich aber auch um eine Verkn√ľpfung zu einer anderen Tabelle oder Mappe handeln. Mit Hilfe der Funktion Instr l√§sst sich eine Zeichenfolge in einem String finden. Die Funktion gibt die genaue Fundstelle zur√ľck. Das bedeutet, dass wenn ein R√ľckgabewert >0 zur√ľckgegeben wird, das gesuchte Zeichen (hier der ‚Äě/‚Äú) sich im Formeltext befindet. √úber die Eigenschaft ColorIndex k√∂nnen Sie dann entsprechend Formelzellen und Zellen mit Verkn√ľpfungen unterschiedlich einf√§rben.