Die VBA-Wissens-Datenbank – Der VBA-Tanker

Beim folgenden Beispiel werden in sekundenschnelle hunderte von Verzeichnissen angelegt. Dabei werden die Namen der Ordner direkt aus einer Excel-Tabelle in einer vorgegebenen Struktur bezogen. Die Anlage aller Verzeichnisse wollen Sie sicherlich nicht händisch vornehmen, oder?

Sub OrdnerAnlegen()
  Dim lngZeile As Long, lngZeileMax As Long, lngSpalteMax As Long
  Dim strVerzeichnis As String, strPfadNeu1 As String,  strPfadNeu2 As String
  Dim strPfadNeu3 As String
  
  With Tabelle1
    strPfad = ThisWorkbook.Path
    On Error Resume Next
    RmDir strPfad & "\" & .Range("A1").Value
    If Dir(strPfad & "\" & .Range("A1").Value, vbDirectory) = "" Then
      MkDir strPfad & "\" & .Range("A1").Value
    End If
   strPfad = strPfad & "\" & .Range("A1").Value
  lngZeileMax = .Range("C" & .Rows.Count).End(xlUp).Row
  
    For lngZeile = 2 To lngZeileMax
     lngSpalteMax = .Cells(lngZeile, .Columns.Count).End(xlToLeft).Column
     Select Case lngSpalteMax
      Case 2
        strVerzeichnis = strPfad & "\" & .Cells(lngZeile, 2).Value
        strPfadNeu1 = strPfad & "\" & .Cells(lngZeile, 2).Value
      Case 3
        strVerzeichnis = strPfadNeu1 & "\" & .Cells(lngZeile, 3).Value
        strPfadNeu2 = strPfadNeu1 & "\" & .Cells(lngZeile, 3).Value
      Case 4
        strVerzeichnis = strPfadNeu2 & "\" & .Cells(lngZeile, 4).Value
        strPfadNeu3 = strPfadNeu2 & "\" & .Cells(lngZeile, 4).Value
      Case 5
        strVerzeichnis = strPfadNeu3 & "\" & .Cells(lngZeile, 5).Value
     End Select
    If Dir(strVerzeichnis, vbDirectory) = "" Then
     MkDir strVerzeichnis
    End If
    Next lngZeile
  End With
End Sub

Bei der folgenden exemplarischen Aufgabenstellung werden beim Datenfilter mehrere Einträge eingestellt. So können aus einer Liste mehrere Länder in einem Vorgang gefiltert werden.

Sub MehrereFilterkriterienEinstellen()
  Dim lngZeileMax As Long, rngBereich As Range, intFilter As Integer
  
  With Tabelle1
  lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
  Set rngBereich = .Range("A1:A" & lngZeileMax)
  intFilter = WorksheetFunction.Match("Stadt", rngBereich.Rows(1), 0)
  If .AutoFilterMode = False Then rngBereich.AutoFilter
   rngBereich.AutoFilter Field:=intFilter, Criteria1:=Array( _
      "Hamburg", "Berlin", "Stuttgart"), Operator:=xlFilterValues
   End With
End Sub

Bei der folgenden Aufgabenstellung soll eine Excel-Liste erzeugt werden, bei der für jede Kostenstelle eine Summe aller Umsätze erzeugt wird. Gerade bei sehr großen Datenmengen gibt es kaum eine schnellere Variante, um Daten erfolgreich zu verdichten.

Sub ZugriffAufEigeneDateiSQLNachKstVerdichten()
  Dim Conn As New ADODB.Connection, rst As New ADODB.Recordset
  Dim strSQL As String, strPfad As String, strVerbindung As String

  With Tabelle3
    .Rows.Delete
    .Range("A1").Value = "Kst"
    .Range("B1").Value = "Umsatz"
    strPfad = ThisWorkbook.FullName
    strVerbindung = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & strPfad & ";HDR=Yes';"
    Conn.Open strVerbindung
    strSQL = "SELECT Kst, Sum(Umsatz) AS Summe1 FROM [Tabelle2$] " & _
          "GROUP BY Kst"
    rst.Open strSQL, Conn
    .Range("A2").CopyFromRecordset rst
    rst.Close
    Conn.Close
  End With
End Sub

Bei der folgenden Aufgabenstellung sollen bestimmte Tabellen in einer Arbeitsmappe nach einer bestimmten Vorgehensweise sortiert werden. Über ein Datenfeld wird diese Sortierung vorgegeben und anschließend umgesetzt.

Sub BenutzerdefiniertSortierungTabellen()
  Dim lngZ As Long, VarDat As Variant

  VarDat = Array("Übersicht", "Kosten", "Leistung", "Daten", "Export", "Diagramme")
  For lngZ = UBound(VarDat) To LBound(VarDat) Step -1
    Worksheets(VarDat(lngZ)).Move Before:=Worksheets(1)
  Next lngZ
End Sub

Beim letzten Beispiel in diesem Artikel sollen auf Basis einer Teilnehmerliste in Excel entsprechende Namensschilder in PowerPoint erstellt werden. Auch diese Aufgabe sollte komplett automatisiert werden. Was Sie dazu brauchen, ist eine PowerPoint-Vorlage für das Namensschild und eine Excel-Tabelle, in der alle Namen verzeichnet sind.

Sub NamensschilderErstellen()
 Dim objPPT As Object, objPPTP As Object,  lngZeileMax As Long, strText As String
 
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 With tbl_Ergebnis
  lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
  For lngZeile = 2 To lngZeileMax
   Set objPPT = CreateObject("powerpoint.application")
   Set objPPTP = objPPT.presentations.Open(ThisWorkbook.Path & "\Namensschild.ppt")
   objPPTP.slides(1).Shapes(1).TextFrame.TextRange.Text = .Range("A" & lngZeile).Value
   objPPTP.slides(1).Shapes(2).TextFrame.TextRange.Text = .Range("A" & lngZeile).Value
   objPPTP.SaveAs ThisWorkbook.Path & "\Namensschild_" & .Range("A" & lngZeile).Value & ".ppt"
   objPPTP.Close
   Set objPPT = Nothing
  Next lngZeile
 End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub