Die VBA-Wissens-Datenbank – Der VBA-Tanker

Irgendwann im Verlaufe einer Programmierung kommt man zu dem Punkt, an dem man sich erinnert, dass man die eine oder andere Aufgabenstellung in VBA bereits schon einmal gelöst hat. Nur wann und wo? Genau aus diesem Sachverhalt heraus entstand der VBA-Tanker. Beim VBA-Tanker handelt es sich um eine VBA-Makro-Datenbank. In dieser wertvollen, ständig erweiterten Makro-Code-Datenbank befinden sich derzeit 6.645 VBA-Lösungen zu Excel, Access, Word, PowerPoint, Outlook und übergreifenden VBA-Themen. Über ausgefeilte Suchfunktionen und eine professionelle Oberfläche kann man in sekundenschnelle die gewünschte Prozedur finden. Die Inhalte der Datenbank stammen in erster Linie direkt aus unseren Projekten, Büchern, Artikeln und Vorträgen. Es handelt sich also um in der Praxis erprobte Lösungen und Code-Schnipsel.
In der VBA-Datenbank selbst können neben den ausgelieferten Prozeduren auch eigene VBA-Beispiele hinterlegt werden. Der VBA-Tanker kommt ohne eine Installation aus und kann jederzeit bequem auf einem USB-Stick überallhin mitgenommen und eingesetzt werden. Bei Bedarf kann die Datenbank zu jeder Zeit mit der im Internet hinterlegten Datenbank synchronisieren werden. Im Internet verfügbar sind ebenso Beispieldateien zu ausgewählten Aufgabenstellungen.
Die VBA-Tanker-Software wird in der Regel zwei- bis dreimal in der Woche aktualisiert und mit neuen Beispielen ausgestattet. Eine Feedback-Funktion und kostenfreie E-Mail-Hotline runden das Software-Paket ab. Lernen Sie in diesem Artikel einige typische Beispiele aus dem VBA-Tanker kennen!
Unikate Werte ermitteln
Beim folgenden Beispiel werden eindeutige Werte aus einer Spalte ermittelt, in einem Dictionary-Objekt verwaltet und senkrecht ausgegeben. Diese Liste kann dann beispielsweise für ein Zellendropdown oder eine Kombinationsfeldliste verwendet werden.
Sub UnikateErmittelnUndAusgeben()
Dim dc As Object, VarDat As Variant, i As Integer
With Tabelle1
Set dc = CreateObject("Scripting.Dictionary")
VarDat = .Range("A2:A" & .UsedRange.Rows.Count)
For i = 1 To UBound(VarDat)
If Not dc.Exists(VarDat(i, 1)) Then
dc.Add VarDat(i, 1), i
End If
Next i
Tabelle1.Range("H1:H" & dc.Count) = Application.WorksheetFunction.Transpose(dc.Keys())
Set dc = Nothing
End With
End Sub
Extremwerte in einer Liste kennzeichnen
Bei der folgenden Aufgabenstellung werden in einer Liste die drei größten Werte ermittelt und mit Hilfe der bedingten Formatierung von Excel aus gekennzeichnet.
Sub Die3GroesstenUmsaetzeKennzeichnen()
Dim rngBereich As Range, lngZeileMax As Long
With Tabelle1
lngZeileMax = .Range("B" & .Rows.Count).End(xlUp).Row
End With
Set rngBereich = Tabelle1.Range("B2:B" & lngZeileMax)
With rngBereich
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$B2>=KGRÖSSTE(" & rngBereich.Address & ";3)"
.FormatConditions(1).Interior.Color = RGB(0, 255, 0)
End With
End Sub
Ein Listenfeld mit Daten aus einer Tabelle füllen
Im folgenden Beispiel wird ein Listenfeld mit Daten aus einer Tabelle befüllt. Dieser Vorgang hört sich erst einmal nicht so kompliziert an. Aber: Standardmäßig stehen für die Befüllung eines Listenfelds nur 10 Spalten zur Verfügung. Was machen Sie, wenn Sie ein paar mehr Spalten haben? Beim nachfolgenden Makro werden mehr als 10 Spalten im Listenfeld angezeigt. Dabei wird die Spaltenbreite der ersten Spalte festgelegt und die restlichen Spaltenbreiten von Excel automatisch bestimmt. Des Weiteren wird die erste Zeile in der Tabelle als Überschrift für das Listenfeld definiert.
Private Sub cmd_OK_Click()
Dim lngZeileMax As Long, Vardat As Variant
lngZeileMax = Datentabelle.Cells(Datentabelle.Rows.Count, 1).End(xlUp).Row
Vardat = Datentabelle.Range("A1:M" & lngZeileMax).Value
With Me.ListBox1
.ColumnHeads = True
.ColumnWidths = "30" 'die erste Spalte auf 30 setzen, Rest Excel überlassen
.ColumnCount = Datentabelle.Range("A1:M1").Columns.Count
.RowSource = Datentabelle.Range("A2:M" & lngZeileMax).Address
End With
End Sub
Hunderte von Verzeichnissen automatisch anlegen
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
Den SVERWEIS verbessern
Über die Tabellenfunktion SVERWEIS können Sie Daten über einen eindeutigen Schlüssel in einer anderen Tabelle/Mappe finden und zuordnen. Leider kann diese Funktion nur Daten finden, die rechts vom Suchbegriff stehen. Auch kann diese Funktion keine noch nicht bekannten Werte finden. In der folgenden Lösung, die kaum eine halbe Seite ausmacht, wird ein Preisupdate über eine eindeutige Artikel-Nr. komplett über ein VBA-Makro vorgenommen. Die neuen Preise werden in Spalte C der Tabelle geschrieben. Neue Artikel werden in der Liste unten angehängt und farbig hervorgehoben.
Sub PreiseAktualisierenAndereTabelle()
Dim lngZeile As Long, lngZeileMax As Long, lngZeileFrei As Long, rngTreffer As Range
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Set wksQuelle = tbl_Preise
Set wksZiel = tbl_Bestand
With wksQuelle
lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
For lngZeile = 2 To lngZeileMax
Set rngTreffer = wksZiel.Range("A:A").Find _
(what:=.Range("A" & lngZeile).Value, lookat:=xlWhole)
If rngTreffer Is Nothing Then
'Neue Nr
lngZeileFrei = wksZiel.Range("A" & wksZiel.Rows.Count).End(xlUp).Row + 1
wksZiel.Range("A" & lngZeileFrei).Value = .Range("A" & lngZeile).Value
wksZiel.Range("C" & lngZeileFrei).Value = .Range("B" & lngZeile).Value
wksZiel.Range("A" & lngZeileFrei).Interior.ColorIndex = 4
Else
'update
rngTreffer.Offset(0, 2).Value = .Range("B" & lngZeile).Value
End If
Next lngZeile
'sortieren
wksZiel.Range("A:C").Sort Key1:=wksZiel.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
End Sub
Den AutoFilter per VBA bedienen
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
Umsätze pro Kostenstelle konsolidieren
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
Tabellen benutzerdefiniert sortieren
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
Namensschilder automatisch erstellen
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