Software für Sie.

Dieser Code funktioniert zwar, wird aber sicher in der Praxis keine Rolle mehr spielen.

Zur Arbeit mit Ribbons (dem Menüband, das Symbolleisten und Menüleisten ersetzt hat) empfehle ich die Website von René Holtz: RibbonX-Workshop

Zur alten Menüleiste:

Sub IstVorhanden() Dim Ctrl As CommandBarControl Dim strTxt As String Dim bolSchalter As Boolean strTxt = "E&xtras" 'das & steht für die Unterstreichung For Each Ctrl In Application.CommandBars("Worksheet Menu Bar").Controls If Ctrl.Caption = strTxt Then bolSchalter = True End If Next Ctrl If bolSchalter = True Then MsgBox "Control gefunden" Else MsgBox "Control nicht gefunden" End If End Sub

Tipp: Auch wenn wir hier die Standardbezeichnungen der Elemente verwenden - übersichtlicher ist es, wenn Sie jedem Element eine aussagekräftige Eigenschaft bei Name vergeben. Commandbutton1 könnte so zum Beispiel cmdNeu genannt werden.

Nun müssen wir uns schon entscheiden: Der Code kann in ein allgemeines Modul (Modul1, Modul2, �) oder in diesem Fall in das Klassenmodul der Userform. Nehmen wir ein allgemeines Modul, muss im Code immer die gesamte Userform angesprochen werden, denn allgemeine Module stehen für die gesamte (in diesem Fall) Mappe - wenn mit mehreren Userforms gearbeitet würde, müsste der Code dort wissen, welche Userform angesprochen werden soll. Wir entscheiden uns hier für das Klassenmodul der Userform, das konkret dieser Userform zugeordnet ist.

Klassenmodul der Userform: Basis für den Code

In das Modul der Userform gelangt man am einfachsten und schnellsten, indem man auf das Element, für das der Code erstellt werden soll, doppelklickt. Wir wollen zuerst einmal dafür sorgen, dass die Userform per Klick auf Schlie�en geschlossen werden kann. Dazu also ein Doppelklick auf den Button (Commandbutton2 war das). Wir gelangen in das Klassenmodul, haben schon den vorbereiteten Code, der für das Klicken auf den Button zuständig ist und tragen dort einfach Unload Me ein:

Private Sub CommandButton2_Click() Unload Me End Sub

Mit F5 kann das auch gleich getestet werden Userform aufrufen und Button anklicken.

Einlesen der Daten aus der Tabelle

Details zu gewähltem Listeneintrag anzeigen

Nun können wir unsere Einträge in der Liste anklicken, aber es passiert natürlich noch nichts. Dass rechts in den Textboxen die Details zum angeklickten Eintrag erscheinen, müssen wir erst eingeben. Es soll etwas beim Anklicken der Listbox passieren - also doppelklicken wir im Editor doppelt auf die Listbox und haben den Rahmen für den Code:

Private Sub ListBox1_Click() End Sub

Zunächst einmal ist wichtig, aus welcher Zeile des Tabellenblattes die Daten kommen sollen, wenn wir auf einen Eintrag in der Listbox klicken.

Dazu nutzen wir die Listindex-Eigenschaft der Listbox. Wenn wir in einer Listbox einen Eintrag auswählen, hat der immer einen Listindex, beginnend mit 0. Ist kein Eintrag ausgewählt, ist der Listindex -1.

Wenn wir also den ersten Eintrag anklicken, sollen die Daten aus der Zeile 2 erscheinen, beim zweiten Eintrag die Daten aus Zeile 3 usw. Wir addieren also zum Listindex einfach 2 und verwenden für die einzelne Textbox den jeweiligen Eintrag aus den Spalten 1 bis 4. Das kann so aussehen:

Dim intIndex As Integer intIndex = ListBox1.ListIndex With Sheets("Daten") TextBox1.Text = .Cells(intIndex + 2, 1) TextBox2.Text = .Cells(intIndex + 2, 2) TextBox3.Text = .Cells(intIndex + 2, 3) TextBox4.Text = .Cells(intIndex + 2, 4) End With

Nun kann allerdings der Fall eintreten, dass mal kein Eintrag gewählt ist. Dann sollen die Textboxen leer sein. Dafür verwenden wir hier eine kleine Schleife - da wir das später nochmal benötigen, lagern wir das in eine separate Sub() aus, die wir dann einfach aufrufen:

Sub TextBoxenLeer() Dim ctrControl As Control For Each ctrControl In Me.Controls If ctrControl.Name Like "TextBox*" Then ctrControl.Text = "" Next End Sub

Damit vervollständigen wir den Code der Listbox, so dass er so aussieht und wir es mit z. B. F5 testen können:

Private Sub ListBox1_Click() Dim intIndex As Integer intIndex = ListBox1.ListIndex If intIndex >= 0 Then With Sheets("Daten") TextBox1.Text = .Cells(intIndex + 2, 1) TextBox2.Text = .Cells(intIndex + 2, 2) TextBox3.Text = .Cells(intIndex + 2, 3) TextBox4.Text = .Cells(intIndex + 2, 4) End With Else TextBoxenLeer End If End Sub

�nderungen aus der Userform in die Tabelle übernehmen

Nun sollen �nderungen, die in den Textboxen vorgenommen werden, auch in die Tabelle übernommen werden. Hierbei ist es besonders wichtig, wie man vorgeht - bei vier Textboxen ist das sicher kein Problem, aber bei grö�eren Datenmasken kann bei einer unzweckmä�igen Technik schon viel überflüssiger Code entstehen. Für den Anfang sei hier jedoch nur auf das Erstellen einer separaten Klasse verwiesen oder auch auf das Verwenden eines Frames und das komplette �bernehmen mit einem Klick. Der Einfachheit halber weisen wir das �bernehmen hier den Textboxen direkt zu.

Damit wir nicht bei jeder Textbox überflüssigen Code wiederholen müssen, bereiten wir eine Sub() vor, die wir dann bei den Textboxen nur noch aufrufen. Die Sub() macht nichts anderes, als einen Wert in die Zelle lngZeile, lngSpalte zu schreiben:

Sub DatenInTabelle(ByVal lngZeile As LongPtr, ByVal lngSpalte As LongPtr, varWert) If lngZeile >= 2 Then Sheets("Daten").Cells(lngZeile, lngSpalte) = varWert End Sub

Damit das bei �nderungen in den Textboxen geschieht, müssen wir dazu noch den Code erstellen - auch hier wieder durch Doppelklick auf die einzelnen Textboxen. Dadurch erhalten wir die Code-Rahmen für die Boxen und fügen nur noch den Verweis auf die Sub ein, die wir gerade erstellt haben. Das sieht dann so aus:

Private Sub TextBox1_Change() DatenInTabelle ListBox1.ListIndex + 2, 1, TextBox1.Text End Sub Private Sub TextBox2_Change() DatenInTabelle ListBox1.ListIndex + 2, 2, TextBox2.Text End Sub Private Sub TextBox3_Change() DatenInTabelle ListBox1.ListIndex + 2, 3, TextBox3.Text End Sub Private Sub TextBox4_Change() DatenInTabelle ListBox1.ListIndex + 2, 4, TextBox4.Text End Sub

Wir sehen, dass auch hier für die Angabe der Zeile der Listindex der Listbox verwendet wird. Da der beim ersten Eintrag 0 ist, die Tabelle aber bei Zeile 2 beginnt, müssen wir hier noch die 2 addieren. Für den Fall, dass mal kein Eintrag in der Listbox gewählt ist (entspricht Listindex = -1), haben wir in Sub DatenInTabelle() noch die Abfrage If lngZeile >= 2 Then .

Damit sollte eine �nderung bei einem gewählten Eintrag übernommen werden. Da es hier um das Prinzip geht, lassen wir hier das Aktualisieren der Listeneinträge bei �nderungen der Spalten 1 und 2 au�en vor. Erwähnt sei nur, dass dies einfach mit ListBox1.List(ListBox1.ListIndex) = möglich ist.

Neuer Eintrag

Fehlt eigentlich nur noch eins: Wie fügt man einen neuen Eintrag hinzu?

In diesem Fall machen wir es ganz einfach: Wir lassen in die erste leere Zelle in Spalte 2 (B) und in die Listbox einen Eintrag vornehmen und diesen in der Listbox auswählen. Der Rest funktioniert dann bereits.

Private Sub CommandButton1_Click() Dim lngZ As LongPtr With Sheets("Daten") lngZ = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(lngZ, 2) = "Neuer Eintrag" End With ListBox1.AddItem "Neuer Eintrag" ListBox1.ListIndex = ListBox1.ListCount - 1 End Sub

Der Nachteil ist, dass die Liste dann diesen Eintrag behält, aber das lässt sich leicht beheben. Am einfachsten schreibt man den Code aus Einlesen der Daten aus der Tabelle in eine separate Sub und lässt die beim Aufruf der Userform und beim Erstellen eines neuen Eintrags ausführen.

Viel Erfolg!

Die 3 steht für Anzahl2, in C2 bis C6 befinden sich die zu zählenden Daten:

=TEILERGEBNIS(3;C2:C6)

Der Code nimmt sich die erste Exceldatei, die im Ordner in der Variablen ist. Die ruft er auf, druckt deren erstes Blatt und schlie�t sie wieder. Mit Dir() wird nun die nächste Datei genommen und die gleiche Prozedur erneut ausgeführt - so lange, bis mit Dir() keine weitere Datei gefunden wird.

Sub AlleDrucken() Dim WB As Workbook Dim strFName As String strFName = Dir("C:\Excel\*.xls") While strFName <> "" Set WB = Workbooks.Open(Filename:=strFName) WB.PrintOut WB.Close strFName = Dir() Wend End Sub

Der Code funktioniert zwar, wie er hier angegeben ist. Allerdings ist die Gefahr eines Fehlers gro�, wenn bereits Dateien geöffnet sind. Zumindest die Prüfung darauf sollte noch mit eingebaut werden.

Im Zusammenhang damit muss auch beachtet werden, ob eine offene Datei gespeichert ist. Wenn nicht, kommt es beim SchlieÃ?en zur entsprechenden â??Speichern?â??-Frage durch Excel und der Code wird angehalten.

Mit Excel 365 wurde das System der Formeln neu erarbeitet, wie mehrfach berichtet wurde. Allerdings handelt es sich dabei eigentlich nur um eine Ergänzung, wenn auch eine sehr sinnvolle und nützliche. Die alten Formeln arbeiten ganz normal weiter - hier muss nicht befürchtet werden, dass irgendetwas nicht mehr funktioniert. Neu sind hingegen die Arrayformeln. Zum Vergleich: Bisher konnte in Formeln mit kompletten Bereichen gearbeitet werden, zum Beispiel mit Summewenn. Die Eingabe der Formeln musste dazu mit Strg + Umschalt + Enter abgeschlossen werden, woraufhin Excel um die Formel geschweifte Klammern {} legte. Die Formel wurde somit als Matrixformel erkannt und es wurde ein kompletter Bereich verarbeitet. Das ERgebnis hingegen stand als ein Wert in einer Zelle.

Natürlich kann die als Arrayfunktion verwendete Wenn-Funktion auch in anderen Funktionen eingesetzt werden. Hier werden alle Zahlen aus C addiert, wenn sie grö�er als 400 sind:

=SUMME(WENN(C2:C13>400;C2:C13))

In dem Fall haben wir natürlich wieder nur ein Ergebnis, nicht eine Matrix aus mehreren Werten

---

Fehler: #Ã?BERLAUF! bzw. #SPILL!

---

Schnittmengenoperator @

Dieses Verhalten hängt unmittelbar mit den Arrayformeln bzw. Arrayfunktionen zusammen. Nehmen wir obige Formel:

=WENN(C2:C13>400;C2:C13;"")

Sie liefert, wie wir gesehen haben, alle Werte, die grö�er als 400 sind, in und unter der Zelle mit der Formel. Was nun aber, wenn wir nur ein Ergebnis benötigen, das erste? Dieser Fall kann auftreten, wenn Formeln über mehrere Zellen gezogen oder wenn Funktionen verschachtelt werden sollen. In diesem Fall setzen wir direkt hinter das Gleichheitszeichen das @-Zeichen:

=@WENN(C2:C13>400;C2:C13;"")

Nun haben wir nur noch ein Ergebnis; in diesem Fall das erste, die 500.

Um bei diesem Beispiel zu bleiben: Setzen wir in der Formel die letzte Zeile absolut (durch das $-Zeichen), kann die Formel nach unten gezogen werden und wir haben als Ergebnis immer den Wert aus den Zellen ab der Zeile mit der Formel:

=@WENN(C2:C$13>400;C2:C$13;"")

Vor Excel 365 konnten natürlich auch einfach benutzerdefinierte Funktionen (UDF) erstellt werden. Wurden sie als Tabellenblattformeln verwendet, galt natürlich das, was generell für Formeln zählte: Es konnte ein Ergebnis pro Zelle erscheinen. Brauchte man mehr Ergebnisse, musste eine Sub() ran, die die Eintragungen in die Zellen vornahm.

Mit den Arrayformeln ab Excel 365 gab und gibt es nun weitaus mehr und vor allem vielfältige Möglichkeiten. So kann eine eigene Funktion einen kompletten Array als Ergebnis liefern - dieser wird dann als übergelaufene Formel in die Zellen neben und unterhalb der Zelle mit der Formel eingetragen.

Als Beispiel eine Funktion, die einen einfachen Monatskalender erstellt:

Function MonatsKalender(ByVal intMonat As Integer, ByVal intJahr As Integer) Dim intArr As Integer, intI As Integer, datDatum As Date Dim arrRet() MonatsKalender = "" intArr = 0 datDatum = CDate("1." & intMonat & "." & intJahr) Do intArr = intArr + 1 ReDim Preserve arrRet(1 To 3, 1 To intArr) arrRet(1, intArr) = Format(datDatum, "DD.MM.YYYY") arrRet(2, intArr) = Format(datDatum, "DDDD") arrRet(3, intArr) = IIf(Weekday(datDatum, vbMonday) = 7, "Frei!", "Arbeiten!") datDatum = datDatum + 1 Loop While Month(datDatum) = intMonat MonatsKalender = arrRet End Function

An die Funktion werden als Parameter die Zahlen für Monat und Jahr übergeben. Die Funktion erhöht dann das Datum so lange, wie der Monat des aktuellen Datums gleich dem übergebenen Monat ist. Bei jedem Datum werden Datumsangabe, Wochentag und ein Eintrag ("Frei!" oder "Arbeiten!") in einen Array eingetragen.

---

Transponieren: MTRANS oder TRANSPOSE

Allerdings wird es in vielen Fällen so sein, dass die Richtung der Ergebnisse nicht wie gewünscht ist. Wir haben im Array die Spalten redimensioniert und die Datumsangaben dort eingetragen, also erscheinen die Datumsangaben auch auf die Spalten verteilt.

Dies ist jedoch kein Problem - das Verhalten des Eintragens der Arrayelemente kann mit der integrierten Tabellenblattfunktion MTRANS() geändert werden. Dazu wird die eigene Funktion (oder bei Bedarf auch andere Funktionen) in Mtrans gesetzt:

=MTRANS(monatskalender(B1;B2))

Schon haben wir den Kalender so, wie wir ihn wahrscheinlich erwartet haben.

Eine Alternative ist, diese Tabellenblattfunktion MTRANS() gleich in der Funktion einzusetzen und den Array bereits vor der Ausgabe zu drehen:

MonatsKalender = Application.WorksheetFunction.Transpose(arrRet)

Zu sehen ist, dass im VBA-Code die englischsprachige Variante genutzt werden muss, die hier Transpose ist.

Integrierte Möglichkeiten von Excel (Funktionen, Methoden) können um ein Vielfaches schneller sein, als wenn man diese selbst per VBA erstellt bzw. nachgestaltet. So war es schon immer ein gro�er Unterschied, ob man die Find-Methode von Excel nutzte oder eine Schleife über viele Zellen laufen lie�, um einen bestimmten Wert zu finden. Insofern kann auch in Betracht gezogen werden, mit VBA Arrayformeln (bzw. integrierte Arrayfunktionen) zu nutzen und deren Ergebnisse zu verarbeiten.

Evaluate()

Vor den Erläuterungen zu den Arrayfunktionen in VBA eine Vorbemerkung zu EVALUATE(), einer Methode, die recht unbekannt, hier aber oft nützlich ist.

Von anderen Sprachen kennt man eval() is evil - in Excel/VBA macht die Methode genau das, was hinter dem Spruch steckt, ist aber bei richtiger Verwendung ungefährlich. Eine Beschreibung ist bei Microsoft zu finden; wir nutzen diese Methode hier, um Formeln/Funktionen interpretieren zu lassen und zu Ergebnissen zu führen.

Dieser Hinweis war wichtig, weil hier in der Folge eine Formel ohne Funktion (also auch ohne Application.WorksheetFunction) verwendet wird, um Arrayformeln in VBA möglichst einfach zu demonstrieren:

Rückgabe: Array

Basis zum Verwenden von Arrayformeln in VBA ist, dass sie Arrays zurückgeben. Schlie�lich ist dies auch beim Einsatz auf dem Tabellenblatt der Fall, nur dass wir dort die Ergebnisse in Zellen sehen. Entsprechend ist auch wichtig zu wissen, dass Bereiche in Arrayergebnissen zwei Dimensionen haben können, strukturiert in Zeilen und Spalten sind.

Verwendung in VBA

Sortieren

Die Funktion SORTIEREN(), die ebenfalls ab Excel 365 zu Verfügung steht, ist vom Prinzip her identisch mit EINDEUTIG(), nur dass sie nicht filtert, sondern sortiert. In der Funktion übergibt man den Bereich und als zweiten Parameter den Index der Spalte, ausgegeben wird der sortierte Bereich.

Beispiel für eine Formel mit dieser Funktion, die nach der zweiten Spalte sortiert:

=SORTIEREN(A2:E15;2)

Mehr Informationen dazu gibt es bei Microsoft: SORTIEREN-Funktion

Auch die Verwendung in VBA ist identisch; die Rückgaben der Arrays und deren Auswertung unterscheiden sich nicht.

---

Sortierennach

---

VBA

In VBA kann es beim Einsatz leicht zu Fehlermeldungen kommen, wenn Funktionen auf die Bereiche angwendet werden, nach denen sortiert werden soll. Soll z. B. einfach nur nach den Datumsangaben in D2:D15 sortiert werden, reicht folgende Anwendung:

Dim a, b a = Range("A2:E15") b = Range("D2:D15") arr = Application.WorksheetFunction.SortBy(a, b, 1)

Wird jedoch bei b eine Funktion verwendet, schimpft Excel schnell. Abhilfe schafft hier, die Formel als String zusammenzustellen und diesen mit EVALUATE() berechnen zu lassen:

Dim strFormel As String strFormel = "=sortby(A2:E15, year(D2:D15), 1, E2:E15,1)" arr = Evaluate(strFormel)

Dieses Beispiel entspricht dem ersten Formelbeispiel. Die Auswertung bzw. weitere Verarbeitung des Ergebnisarrays würde dann wie bei EINDEUTIG() erfolgen; an die Stellen der MsgBoxen müsste der Code, der das Weitere erledigen soll:

Sub Sortierennach_vba() Dim arr, intI As Integer, intAnzahlEl As Integer Dim strFormel As String strFormel = "=sortby(A2:E15, year(D2:D15), 1, E2:E15,1)" arr = Evaluate(strFormel) intAnzahlEl = Application.WorksheetFunction.CountA(arr) MsgBox "Ubound: " & UBound(arr) & vbNewLine & "Anzahl: " & intAnzahlEl If intAnzahlEl = UBound(arr) Then ' Es gibt nur eine Zeile MsgBox arr(2) & ", " & arr(3) & ": " & Format(arr(4), "DD.MM.YYYY") Else ' Mehrere Zeilen For intI = 1 To UBound(arr) MsgBox arr(intI, 2) & ", " & arr(intI, 3) & ": " & Format(arr(intI, 4), "DD.MM.YYYY") Next End If End Sub

Datenfilter, Autofilter und seit Excel 365 nun auch eine Funktion FILTER() - verschiedene Möglichkeiten gibt es ja. Was konkret verwendet wird, wird sich immer nach den konkreten Umständen richten müssen. Mit der Funktion haben wir nun eine schnelle und sehr flexible Variante, die vor allem auch bei der Nutzung durch VBA dank reduzierter Ergebnismengen zu besseren Laufzeiten führen kann. Ausführliche Informationen gibt es natürlich bei Microsoft: FILTER-Funktion.

Mehrere Suchkriterien können durch das +-Zeichen für Oder bzw. das *-Zeichen für Und verknüpft werden. So sucht die folgende Formel nach Einträgen, die "Berlin" oder "Hamburg" enthalten:

=FILTER(A2:F15;(D2:D15="Berlin")+(D2:D15="Hamburg");"Nix gefunden!")

Diese Formel sucht nach Zeilen, die als Ort "Berlin" enthalten und ein Datum aus dem Jahr 2015 haben und deren Beträge grö�er als 200 sind:

=FILTER(A2:F15;(D2:D15="Berlin")*(JAHR(E2:E15)=2015)*(F2:F15>200);"Nix gefunden!")

Verknüpfungen von Und und Oder sind natürlich auch möglich. Dabei muss allerdings auf die richtige Klammersetzung geachtet werden. Die nächste Formel sucht Einträge mit ("Berlin oder "Hamburg") und aus dem Jahr 2015 und mit Beträgen grö�er als 200:

=FILTER(A2:F15;((D2:D15="Berlin")+(D2:D15="Hamburg"))*(JAHR(E2:E15)=2015)*(F2:F15>200);"Nix gefunden!")

---

VBA

Der Einsatz in VBA ist nahezu identisch, wenn mit EVALUATE() gearbeitet wird. Die Formel wird dazu als String zusammengesetzt und mit Evaluate wird diese Berechnung durchgeführt:

strFormel = "=filter(A2:E15, D2:D15=""Berlin"", """")" arr = Evaluate(strFormel)

Die weitere Verarbeitung des Ergebnisarrays erfolgt wie bei der Funktion EINDEUTIG() unter Weiterverarbeitung des Ergebnisarrays beschrieben. Hier ein Beispiel im Ganzen, das die letzte Formel nutzt:

Sub Filter_vba() Dim arr, intI As Integer, intAnzahlEl As Integer Dim strFormel As String strFormel = "=FILTER(A2:F15,((D2:D15=""Berlin"")+(D2:D15=""Hamburg""))*(year(E2:E15)=2015)*(F2:F15>200),""Nix gefunden!"")" arr = Evaluate(strFormel) intAnzahlEl = Application.WorksheetFunction.CountA(arr) MsgBox "Ubound: " & UBound(arr) & vbNewLine & "Anzahl: " & intAnzahlEl If intAnzahlEl = UBound(arr) Then ' Es gibt nur eine Zeile MsgBox arr(2) & ", " & arr(3) & ": " & Format(arr(4), "DD.MM.YYYY") Else ' Mehrere Zeilen For intI = 1 To UBound(arr) MsgBox arr(intI, 2) & ", " & arr(intI, 3) & ": " & Format(arr(intI, 4), "DD.MM.YYYY") Next End If End Sub

Das Erstellen von Zahlenreihen mit bestimmten Abständen ist seit Excel 365 denkbar einfach - es gibt ja die Funktion SEQUENZ(). Die folgende Formel liefert eine Liste über 15 Zeilen in einer Spalte, beginnend mit 1 und mit einem Abstand von 1:

=SEQUENZ(15;1;1;1)

Benötigen Sie eine Reihe von Datumsangaben für Ihren 14-tägigen Urlaub, können Sie das verwenden:

=SEQUENZ(14;1;"05.02.2019";1)

Natürlich müssen die Zahlen als Datum formatiert werden.

Auch Uhrzeiten sind möglich - hier ab 08:00 mit einem Abstand von einer halben Stunde (als Zeit formatieren):

=SEQUENZ(17;1;"08:00";"00:30")

---

Verwendung in VBA

In VBA wird die Funktion am besten mit Application.WorksheetFunction.Sequence genutzt, um den Array mit den Zahlen zu erhalten. Beispiele:

• arr = Application.WorksheetFunction.Sequence(10, 1, "08:00", "00:30")
• arr = Application.WorksheetFunction.Sequence(10, 1, CDate("05.02.2019"), 1)

---

Verwendung/Verarbeitung des Ergebnisarrays

Bei der Verarbeitung des Ergebnisarrays ist darauf zu achten, dass die einzelnen Zahlen als Zeilen vorliegen - Ubound ist also die Zeilenzahl. Wird nur eine Spalte verwendet (immer die 1 in der Funktion), ist der Ubound auch gleichzeitig die Anzahl der Zahlen. In diesem Fall muss also auf die erste Spalte jeder Zeile zugegriffen werden:

For intI = 1 To UBound(arr) MsgBox intI & ": " & arr(intI, 1) Next

Hinweis: Bei Ausgaben von Datumsangaben und Zeiten müssen diese noch formatiert werden, zum Beispiel Format(arr(intI, 1), "hh:nn") für die Zeitangaben.

Etwas anders verhält es sich, wenn die Sequenz mehrspaltig erstellt wurde, zum Beispiel mit zwei Spalten:

arr = Application.WorksheetFunction.Sequence(10, 2, "08:00", "00:30")

Dann wird mit arr(intI, 1) nur die erste Spalte verarbeitet; bei einer Ausgabe wären das nur die vollen Stunden. In dem Fall muss dann auch auf die zweite Spalte zugegriffen werden:

MsgBox intI & ": " & Format(arr(intI, 1), "hh:nn") & vbTab & Format(arr(intI, 2), "hh:nn")

Das letzte Beispiel im Ganzen zum Testen:

Sub Sequenz_vba() Dim arr, intI As Integer arr = Application.WorksheetFunction.Sequence(10, 2, "08:00", "00:30") For intI = 1 To UBound(arr) MsgBox intI & ": " & Format(arr(intI, 1), "hh:nn") & vbTab & Format(arr(intI, 2), "hh:nn") Next End Sub

Funktionen für Zufallszahlen bzw. Möglichkeiten, sie errechnen zu lassen, gab es ja schon vor Excel 365. Seit dieser Excelversion gibt es nun auch ZUFALLSMATRIX (), die den Umgang damit etwas vereinfacht. Statt mit Rnd() und * Obergrenze und + Obergrenze zu rechnen, notiert man diese Anforderungen einfach als Parameter in der Funktion selbst. Eine Beschreibung im Detail gibt es bei Microsoft: ZUFALLSMATRIX-Funktion.

Bei dieser Funktion ist man nicht nur auf Zahlen beschränkt, die als solche aussehen, sondern es können auch zufällige Datumsangaben und Uhrzeiten erstellt werden:

• ZUFALLSMATRIX(15;1;"1.1.2020";"15.06.2020";WAHR)
• ZUFALLSMATRIX(15;1;"08:00";"16:00")

Zwei Dinge müssen hier jedoch beachtet werden:

Der letzte Parameter [ganze_zahl] muss bei Uhrzeiten weggelassen oder auf FALSCH bzw. 0 gesetzt werden, da die reinen Zahlen bei Uhrzeiten immer zwischen 0 und 1 sind.

Wie bei allen Arrayformeln nimmt Excel dabei keine Formate mit. Datumsangaben und Zeiten müssen also i. d. R. im Ergebnis neu formatiert werden. Hilfreich kann da der Pinsel Format übertragen sein.

Das Sortieren der Zahlen geht einfach, indem die Funktion SORTIEREN() verwendet wird:

=SORTIEREN(ZUFALLSMATRIX(15;1;"1.1.2020";"15.06.2020";1))

---

Verwendung in VBA

In VBA wird ein Array durch Nutzung der Funktion so erzeugt, wie es bei der reinen Formel ist. Beispiele:

• arr = Application.WorksheetFunction.RandArray(10, 1, CDate("1.1.2020"), CDate("15.06.2020"))
• arr = Application.WorksheetFunction.RandArray(10, 1, CDate("08:00"), CDate("16:00"))

Die Verarbeitung des Ergebnisarrays erfolgt so, wie es bei SEQUENZ() beschrieben ist. Die einzelnen Daten liegen also in Zeilen vor; bei einer Spalte ist dies der Ubound. Also muss auch auf die erste Spalte zugegriffen werden:

For intI = 1 To UBound(arr) MsgBox intI & ": " & Format(arr(intI, 1), "DD:MM.YYYY") Next

Im Beispiel ist auch schon zu sehen, dass etwaige Ausgaben formatiert werden müssen.

Werden mehrere Spalten erzeugt, muss das beim Zugreifen auf die Arrayelemente beachtet werden:

For intI = 1 To UBound(arr) MsgBox intI & ": " & Format(arr(intI, 1), "hh:nn") & vbTab & Format(arr(intI, 2), "hh:nn") Next

Wie bei der Formellösung kann der Array auch sortiert werden:

arr = Application.WorksheetFunction.Sort(arr)

Auch hier muss natürlich beachtet werden, dass die Daten zweispaltig sein können, wenn der zweite Parameter in der Funktion entsprechend gesetzt ist. Nach der zweiten Spalte würde dann so sortiert:

arr = Application.WorksheetFunction.Sort(arr, 2)

Ob das Sinn macht, ist allerdings eine andere Frage.

Beim häufigen Einsatz von Arrayfunktionen in VBA kann es durch die ständige Verwendung von Application.WorksheetFunction natürlich auch schnell unübersichtlich werden. Abhilfe schafft, das als Object zu deklarieren und sich in der Folge immer darauf zu beziehen.

So könnte man wksFkt als Objektvariable verwenden und so deklarieren:

Dim wksFkt As Object Set wksFkt = Application.WorksheetFunction

In der Folge kann das so verwendet werden:

arr = wksFkt.RandArray(5, 1, CDate("08:00"), CDate("16:00")) arr = wksFkt.Sort(arr)

Der Vollständigkeit halber sollte der Speicher aber auch wieder freigegeben werden:

Set wksFkt = Nothing

Das Beziehen auf den Bereich mit dem Ergebnis, zum Beispiel F3:G14, würde zunächst einen Erfolg liefern. Allerdings wird das Problem ersichtlich, wenn sich im Ergebnis, das man verwenden will, die Ergebnismenge ändert, indem zum Beispiel eine Zeile mehr in der Basistabelle plötzlich das Filterkriterium erfüllt. In dem Fall bliebe der Bezug auf den Bereich F3:G14 bestehen - das zusätzliche Ergebnis aus der Berechnung bliebe unberücksichtigt.

Aus diesem Grund arbeitet Excel mit Referenzen auf komplette Ergebnisse. Eine solche Adresse sieht man, wenn man irgendwo ein Gleichheitszeichen eingibt und anschlie�end über den Bereich mit dem Ergebnis der Berechnung zieht - Excel trägt dann in die Formel einen Bezug wie E3# ein. Dabei handelt es sich um die Zelle mit der Formel und das Rautezeichen signalisiert, dass das Ergebnis dieser Berechnung für weitere Berechnungen gewünscht ist.

Im Beispiel auf der Grafik ist die Basistabelle in A3:C14. In E3 befindet sich die Formel zum Sortieren dieser Tabelle:

=SORTIEREN(A3:C14)

Das Ergebnis flieÃ?t nun als Ergebnis um die Zelle E3.

Nun soll diese sortierte Ergebnismenge In I3 nach dem Monat Juni gefiltert werden. Es soll sich dabei also auf das vorherige Ergebnis bezogen werden. In die FILTER-Funktion wird deshalb nicht E3 als Matrix eingetragen, auch nicht E3:G14, wo sich das komplette Ergebnis befindet. Verwendet wird als Matrix E3#, damit die Filter-Funktion weiÃ?, dass es sich um ein dynamisches Ergebnis handelt. Der Rest bleibt wie gehabt:

=FILTER(E3#;F3:F14="Juni")

Wenn nun in der Basistabelle ein weiterer Monat auf Juni geändert wird, passt sich das Ergebnis auch beim Filtern dynamisch an und wird erweitert.

---

Verwenden eines Arrayergebnisses in VBA

In VBA kann dieser Bezug ebenfalls verwendet werden, indem er im Range-Objekt als Adresse angegeben wird:

Dim arr, intI As Integer arr = Range("I3#") For intI = 1 To UBound(arr) MsgBox intI & ": " & arr(intI, 1) & vbTab & arr(intI, 2) & vbTab & arr(intI, 3) Next

Auch mit EVALUATE ist es möglich:

Dim arr, intI As Integer arr = Evaluate("I3#") For intI = 1 To UBound(arr) MsgBox intI & ": " & arr(intI, 1) & vbTab & arr(intI, 2) & vbTab & arr(intI, 3) Next

In PHP kann man sehr übersichtlich mit assoziativen Arrays arbeiten, wie zum Beispiel

$MeinArray['Vorname'] = 'Manfred';

In Excel geht das auch:

Setzen Sie im VBA-Editor unter Extras ▸ Verweise ein Häkchen vor Microsoft Scripting Runtime oder verwenden Sie Late Binding wie in den folgenden Beispielen. Nun können Sie wie folgt mit assoziativen Arrays arbeiten:

Basis ist das Dictionary oder die Collection. Dabei spielen immer Paare eine Rolle: Key=Item, also ein Schlüsselname und der Eintrag dazu. In den folgenden Beispielen wird der Einfachheit halber (und weil Collection ein paar Nachteile hat) nur das Dictionary verwendet.

Im Code sind hier die einzelnen Inhalte (Keys, Items) zum besseren Verständnis hardcodiert, also fest eingetragen. An dieser Stelle können natürlich auch Variablen oder Zellen verwendet werden, zum Beispiel Spalten- oder Zeilenüberschriften und Zellen mit Daten.

Eine Ebene

Im Beispiel sind die Key=Item-Paare auf einer Ebene. Das heiÃ?t, es darf auch keine zwei gleichnamigen Keys geben, sonst wird eine Fehlermeldung ausgegeben.

Sub AssozArray_Einfach() Dim dict, varKey, varKeys, varItems Dim intI As Integer Set dict = CreateObject("Scripting.Dictionary") dict.Add "name", "Müller" dict.Add "vorname", "Johann" dict.Add "wohnort", "Berlin" MsgBox dict("vorname") & " " & dict("name") & " wohnt in " & vbNewLine & dict("wohnort") & "." 'For Each varKey In dict.keys ' MsgBox varKey & vbNewLine & dict(varKey) 'Next varKeys = dict.Keys varItems = dict.Items For intI = 0 To dict.Count - 1 MsgBox varKeys(intI) & ": " & vbNewLine & varItems(intI) Next Set dict = Nothing End Sub

Die MsgBox zeigt, wie die Syntax Dictionary(Key) verwendet werden kann, um auf die einzelnen Elemente zuzugreifen. Darunter sind zwei Schleifen. Mit ihnen wird demonstriert, wie alle Elemente des Dictionarys ausgegeben werden können.

---

Verschachtelungen, mehrere Ebenen

Elemente von Arrays können wiederum Arrays sein. Dies geht auch bei den assoziativen Arrays bzw. Dictionarys in VBA - auch hier kann verschachtelt werden. Dabei trifft genau das Prinzip der Paare zu, nur dass an der Stelle des Items eine weitere Sammlung (Dictionary oder Collection) ist. Hier wird ein temporäres Dictionary verwendet, das vor jeder Verschachtelung neu erzeugt und danach wieder auf Nothing gesetzt wird. Vorbelegen oder �berschreiben der Items in den einzelnen Schritten funktioniert nicht, da sonst nur auf die letzten Einträge referenziert wird.

Wir wollen im Beispiel ein Dictionary aus sechs Personen erzeugen, das sind also sechs verschiedene Keys. Diesen sechs Personen können nun Details (Nachname, Vorname, Wohnort) zugeordnet werden, müssen aber nicht. So kann der Platz für eine Person auch nur reserviert sein, ohne dass Details enthalten sind.

Die Personen insgesamt sind die Einträge in dicPersonen mit den Keys Person x. Werden Details zugeordnet, erfolgt das Speichern zunächst im temporären Dictionary dictDetails, das dann als Item der Person zugeordnet wird. Gibt es keine Details, wird als Item einfach ein String verwendet.

Sub AssozArray_Levels() Dim dicPersonen, dictDetails, varKey, varKey1 Dim strAusg As String Set dicPersonen = CreateObject("Scripting.Dictionary") Set dictDetails = CreateObject("Scripting.Dictionary") dictDetails.Add "nachname", "Müller" dictDetails.Add "vorname", "Klaus" dictDetails.Add "wohnort", "Berlin" dicPersonen.Add "Person 1", dictDetails Set dictDetails = Nothing Set dictDetails = CreateObject("Scripting.Dictionary") dictDetails.Add "nachname", "Beispielfrau" dictDetails.Add "vorname", "Bärbel" dictDetails.Add "wohnort", "Hamburg" dicPersonen.Add "Person 2", dictDetails Set dictDetails = Nothing Set dictDetails = CreateObject("Scripting.Dictionary") dictDetails.Add "nachname", "Mustermann" dictDetails.Add "vorname", "Franz" dictDetails.Add "wohnort", "Leipzig" dicPersonen.Add "Person 3", dictDetails Set dictDetails = Nothing dicPersonen.Add "Person 4", "Nicht vergeben." Set dictDetails = CreateObject("Scripting.Dictionary") dictDetails.Add "nachname", "Sonne" dictDetails.Add "vorname", "Klara" dictDetails.Add "wohnort", "München" dicPersonen.Add "Person 5", dictDetails Set dictDetails = Nothing dicPersonen.Add "Person 6", "Auch nicht vergeben." MsgBox "Testausgabe: " & vbNewLine & dicPersonen("Person 1")("wohnort") & vbNewLine & dicPersonen("Person 2")("wohnort") strAusg = "" For Each varKey In dicPersonen.keys strAusg = strAusg & vbNewLine & "Person: " & varKey & vbNewLine On Error Resume Next For Each varKey1 In dicPersonen(varKey).keys strAusg = strAusg & "key: " & varKey1 & vbTab & "item: " & dicPersonen(varKey)(varKey1) & vbNewLine Next If Err.Number = 92 Then strAusg = strAusg & vbTab & vbTab & "item: " & dicPersonen(varKey) & vbNewLine Err.Clear End If Next MsgBox strAusg Set dicPersonen = Nothing End Sub

In der MsgBox mit der Testausgabe ist zu sehen, wie die Items ausgegeben werden können. Wir haben hier also nicht nur den Key einer Ebene, sondern hier wird mit Klammerpaaren bis zur unteren Ebene gearbeitet.

Schwieriger ist es mit der kompletten Ausgabe per Schleife. Hätten wir konsequent bei jeder Person eine Verschachtelung mit den Details, würde so etwas reichen:

For Each varKey In dicPersonen.keys strAusg = strAusg & vbNewLine & "Person: " & varKey & vbNewLine For Each varKey1 In dicPersonen(varKey).keys strAusg = strAusg & "key: " & varKey1 & vbTab & "item: " & dicPersonen(varKey)(varKey1) & vbNewLine Next Next

Da aber zwischendurch unverschachtelte Items direkt auf der ersten Ebene sind (Person 4 + 6), käme es hier zu einer Fehlermeldung, dem Fehler 92. Der wird abgefangen und separat behandelt; hier wird der Eintrag direkt ausgegeben. Der Schlüssel, also der Key, ist hier ja die oberste Ebene, die Person selbst.

---

Dynamische Arrayformel

Website-Tipp

Hier gibt es gute Erklärungen von Paul Kelly (englisch): Excel VBA Dictionary â?? A Complete Guide

Ab Excel 365

Zunächst muss das Blatt mit dem Monatsnamen des aktuellen Datums ermittelt werden. Das geht mit Indirekt:

=INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")

Diese Formel liefert die komplette erste Zeile mit den Datumsangaben des aktuellen Monats. Sie kann nun in der Funktion FILTER() als Suchbereich verwendet werden. Damit können alle Mitarbeiter des Tages ermittelt werden (hier bis Zeile 30):

=FILTER(INDIREKT(TEXT(HEUTE();"MMMM")&"!A2:AE30");INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")=HEUTE())

Die Formel gibt aus der Datumsspalte alle Einträge zurück, die bis Zeile 30 liegen.

Da aber mehr Zeilen (wie hier bis 30) verwendet werden müssen (die maximale Anwesenheit muss ja berücksichtigt werden), liefert diese Formel für die leeren Zellen, in denen also kein Mitarbeiter eingetragen ist, jeweils eine 0. Das kann also weder mit ANZAHL() noch mit ANZAHL2() gezählt werden, da sonst die 0 immer einflie�en würde.

Wir verwenden im Beispiel SUMME(Wenn( und lassen die Einträge zählen, die <> 0 sind:

=SUMME(WENN(FILTER(INDIREKT(TEXT(HEUTE();"MMMM")&"!A2:AE30");INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")=HEUTE())<>0;1;0))

Ã?ltere Versionen

Hier ist die Formel etwas länger:

=ANZAHL2(INDIREKT(TEXT(HEUTE();"MMMM")&"!"&LINKS(ADRESSE(1;VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"));4);1+(VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"))>26))&"2:"&LINKS(ADRESSE(1;VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"));4);1+(VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"))>26))&"1000"))

Der Code funktioniert noch. Aber ob er im Zeitalter der Ribbons/Menübänder noch gebraucht wird?

Sub ID_anzeigen() Dim intZ as integer, objY As CommandBar, objX As CommandBarControl range("A1") = "ID": range("B1") = "Name": range("C1") = "Index": range("D1") = "Symbolleiste" intZ = 2 For Each objY In CommandBars For Each objX In CommandBars(objY.Name).Controls Cells(intZ, 1) = objX.ID Cells(intZ, 2) = objX.Caption Cells(intZ, 3) = objX.Index Cells(intZ, 4) = objY.Name intZ = intZ + 1 Next Next End Sub

Grüne Formatierung

Rote Formatierung

Gelbe Formatierung

Wenn nun Zahlen eingetragen werden, sollte das beim ersten Land funktionieren, die Hintergründe müssten automatisch entsprechend der Zahlen formatiert werden. Allerdings müssen die Schritte noch für die anderen beiden Länder wiederholt werden. Beim mittleren Land aufpassen; die Zellen in MIN und MAX müssen hier mit Semikolon getrennt werden, weil es keine Bis-Bereiche sind, sondern auseinanderliegende Zellen.

---

Auswertung: Matrixformel

Unter der Tabelle sollen nun noch zu jedem Land die grünen, roten und gelben Zellen gezählt werden. Das Problem: Mit einer reinen Formellösung können keine farbigen Zellen gezählt werden.

Ein Lösungsansatz ist, zu zählen, wie viele Zellen in der jeweiligen Spalte grö�er bzw. kleiner als die Zellen daneben sind. Damit wir nicht jede Zeile einzeln berücksichtigen müssen, verwenden wir dazu eine Matrixformel, die den Bereich einer Spalte über alle Zeilen hinweg erfasst.

Hinweis: Die geschweiften Klammern nicht eingeben, sondern die Eingabe der Formel mit Strg + Umschalt + Enter abschlieÃ?en. Damit erscheinen die geschweiften Klammern automatisch. Ab Excel 365 sind die geschweiften Klammern nicht mehr notwendig.

Wir beginnen beim ersten Land, hier mit der Formel in E24. Es sollen die Zellen gezählt werden, die in den Zeilen die niedrigsten Preise haben. Dabei zählen wir aber nicht, sondern wir addieren für jede dieser niedrigsten Zellen die 1. Wir bilden also die Summe, hier das Grundgerüst:

=SUMME( wenn Zahl in der Zeile am niedrigsten ; dann addiere 1; sonst addiere 0))

Wir verwenden hier diese Logik (andere Varianten gibt es natürlich auch):

Wenn die Zahl beim Land 1 (E) kleiner als die Zahl beim Land 2 (F) ist, dann wenn die Zahl beim Land 1 (E) auch kleiner als die beim Land 3 (G) ist, dann addiere 1, sonst 0, sonst 0.

Wir addieren hier also zweimal 0 - einmal für die erste Bedingung (Land 1 nicht kleiner als Land 2) und einmal für die zweite Bedingung (Land 1 nicht kleiner als Land 3).

Diese Struktur bauen wir in die Formel ein, so dass die (an Strg + Umschalt + Enter denken!) nun so aussieht:

{=SUMME(WENN(E2:E19<F2:F19;WENN(E2:E19<G2:G19;1;0);0))}

Damit haben wir die Anzahl der grünen Zellen beim Land 1 in E24. Die gleiche Formel kommt zu den anderen Ländern. Vorsicht, die kann aber nicht gezogen werden, weil die Zellen in den Formeln angepasst werden müssen.

Ebenfalls die gleiche Formel, nur mit dem grö�er als >, kommt in die Zeile 26, wo die roten Zellen gezählt werden:

{=SUMME(WENN(E2:E19>F2:F19;WENN(E2:E19>G2:G19;1;0)))}

Bei den gelben Zellen geht es einfacher - einfach alle Zellen in der Spalte zählen und die grünen und roten subtrahieren:

=ANZAHL(E2:E19)-E24-E26

Eine Beispieldatei mit dieser Lösung: 326_preisvergleiche.xlsx

Basis: In Spalte A (im Code also 1) stehen aufsteigend sortiert und ohne leere Zellen dazwischen die Zeiten.

Zum Umsetzen der Aufgabenstellung benötigen wir vier einzelne Routinen. Diesen müssen wir zwei Variablen zur Verfügung stellen, die deshalb ganz am Anfang des Moduls deklariert werden müssen:

Private lngZ As LongPtr Private bolC As Boolean

In der ersten Routine Start() löschen wir die Zellinhalte neben den Uhrzeiten und legen in lngZ die erste Zeile mit einer Uhrzeit fest. Dazu setzen wir bolC auf True. Das Makro, das später die Eintragungen vornimmt, wird diese Variable prüfen und den Vorgang nur fortsetzen, wenn diese auf True gesetzt ist. Anschlie�end starten wir den Vorgang mit der Sub ZeitFestLegen():

Sub Start() lngZ = 2 'erste Zeile mit Uhrzeit Range(Cells(lngZ, 2), Cells(Rows.Count, 3)).ClearContents bolC = True ZeitFestLegen End Sub

Die Sub ZeitFestLegen() hat nur folgende Aufgaben:

• prüfen, ob in Spalte A der Zeile lngZ eine Zeit steht,
• prüfen, ob bolC noch True ist,
• wenn zweimal ja: festlegen, dass bei der Zeit in Zeile lngZ etwas passiert (das Makro Eintragen ausführen) - zunächst ist das hier die Zeit in Zeile 2, weil wir die bereits in lngZ festgelegt haben:

Sub ZeitFestLegen() Dim datZeitAngabe As Date If Cells(lngZ, 1).Value = "" Then Exit Sub If bolC = False Then MsgBox "Makro wurde angehalten" Exit Sub End If datZeitAngabe = Cells(lngZ, 1).Value Application.OnTime datZeitAngabe, "Eintragen" End Sub

Nun wei� der Code, wann etwas passieren soll, nämlich bei der ersten Zeit. Mit der Sub Eintragen() legen wir fest, was passieren soll. Hier werden einfache Texte in die Nachbarzellen eingetragen.

Nach dem Eintragen wird die Zeile lngZ um 1 erhöht und wieder die Sub ZeitFestLegen aufgerufen, die nun dafür sorgt, dass das Ganze bei der nun in der nächsten Zeile gefundenen Zeit von vorn losgeht - wenn eine Zeit in dieser neuen Zelle steht und bolC immer noch True ist:

Sub Eintragen() Cells(lngZ, 2).Value = "Hallo, Spalte B" Cells(lngZ, 3).Value = "Hallo, Spalte C" lngZ = lngZ + 1 ZeitFestLegen End Sub

Das sollte schon mal funktionieren. Aber: Es gibt für den Anwender keine Möglichkeit, das vorzeitig abzubrechen. Bei der nächsten Zeit wird eingetragen und sofort die neue Zeit festgelegt.

Deshalb sollten wir eine Möglichkeit einbauen, den Wert der Variablen bolC auf False zu setzen, damit die Sub ZeitFestLegen den Vorgang abbricht. Dazu reicht das Stück Code, das man vielleicht an einen Button o. ä. binden kann:

Sub Stoppen() bolC = False End Sub

Die verschiedenen Deklarationen sind wichtig, um das Funktionieren sowohl in der 64-Bit-Version des Microsoft Office (also nicht von Windows) als auch in der 32-Bit-Version zu gewährleisten.

#If VBA7 Then Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As LongPtr) As LongPtr #Else Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long #End If Sub ComputerName() Dim lngTemp As LongPtr, strPCName As String strPCName = Space(256) lngTemp = GetComputerName(strPCName, Len(strPCName)) MsgBox strPCName End Sub

Das kann man natürlich auch als UDF erstellen:

Function ComputerName1() Dim lngTemp As LongPtr, strPCName As String strPCName = Space(256) lngTemp = GetComputerName(strPCName, Len(strPCName)) ComputerName1 = strPCName End Function

In die Zelle wird einfach =computername1() eingetragen.

Natürlich kann man den gesamten Pfad am Backslash splitten oder andere Stringoperationen anwenden. Am einfachsten ist es aber sicher, wenn man sich mit Dir() den Dateinamen zurückgeben lässt - das geht auch mit allen Dateien, nicht nur mit Exceldateien.

Dir()

Rein für den Dateinamen wäre dies eine einfache Möglichkeit:

Sub DateinamenExtrahieren() Dim varDName varDName = Application.GetOpenFilename If varDName = False Then MsgBox "Nichts gewählt." Else varDName = Dir(varDName) MsgBox varDName End If End Sub

Für alle Angaben aus dem Pfad, also Ordner und Datei, könnte folgende Variante genutzt werden:

Sub DateiPfad() Dim strGesamt As String, strDatei As String, strOrdner As String strGesamt = Application.GetOpenFilename strDatei = Dir(strGesamt) strOrdner = Left(strGesamt, Len(strGesamt) - Len(Dir(strGesamt))) MsgBox strDatei & vbNewLine & strOrdner & vbNewLine & strGesamt End Sub

Wenn davon ausgegangen werden kann, dass die Zeichenfolge des Dateinamens einmalig im Pfad ist, kann auch einfach ersetzt werden:

Sub DateiAusPfad2() Dim varPfad, strOrdner As String, strDatei As String varPfad = Application.GetOpenFilename If varPfad <> False Then strDatei = Dir(varPfad) strOrdner = Replace(varPfad, strDatei, "") MsgBox strDatei & vbNewLine & strOrdner End If End Sub

---

Regulärer Ausdruck

Noch eine Variante für die Freunde regulärer Ausdrücke:

Sub DateiAusPfad3() Dim varDName, Regex As Object, regMatches, regMatch varDName = Application.GetOpenFilename If varDName = False Then MsgBox "Nichts gewählt." Else If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.+[\\\/])(.*)$" Set regMatches = Regex.Execute(varDName) MsgBox regMatches(0).SubMatches(1) Set Regex = Nothing End If End Sub

Der Schrägstrich wurde aufgenommen, weil Pfade in Onedrive gespeicherter Dateien mit Schrägstrich geliefert werden.

Sollen Ordner und Dateiname zurückgegeben werden, wäre dies möglich:

Sub DateiAusPfad4() Dim varPfad, strOrdner As String, strDatei As String Dim Regex As Object, regMatches, regMatch varPfad = Application.GetOpenFilename If varPfad <> False Then If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.+[\\\/])(.*)$" Set regMatches = Regex.Execute(varPfad) strOrdner = regMatches(0).SubMatches(0) strDatei = regMatches(0).SubMatches(1) Set Regex = Nothing MsgBox strDatei & vbNewLine & vbNewLine & strOrdner End If End Sub

Die integrierte Funktion =ZELLE("Dateiname";A1) liefert den kompletten Pfad bis zum Tabellenblatt. Der Dateiname ist dabei in eckige Klammern eingeschlossen: Pfad[Dateiname]Blattname. Mit einem regulären Ausdruck können die einzelnen Bestandteile ausgegeben werden (ggf. noch Fehlerbehandlung einbauen):

Sub DateiAusZellFunktion() Dim strPfad, strOrdner As String, strDatei As String, strBlatt As String Dim Regex As Object, regMatches, regMatch strPfad = Evaluate("=cell(""filename"",A1)") If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.*)\[(.*)\](.*)$" Set regMatches = Regex.Execute(strPfad) strOrdner = regMatches(0).SubMatches(0) strDatei = regMatches(0).SubMatches(1) strBlatt = regMatches(0).SubMatches(2) Set Regex = Nothing MsgBox strBlatt & vbNewLine & strDatei & vbNewLine & strOrdner End Sub

---

Dynamische Matrixformel (Arrayformel) und verschütteter Array

Per benutzerdefinierter Funktion können seit Excel 365 auch die einzelnen Ordner bzw. Bestandteile eines Pfades in Zellen ausgegeben werden. Dazu diese Funktion als Beispiel:

Function PfadDetails(ByVal strPfad As String) PfadDetails = "" If strPfad <> "" Then Select Case True Case InStr(1, strPfad, "\") > 0: PfadDetails = Split(Replace(strPfad, "\\", "\"), "\") Case InStr(1, strPfad, "/") > 0: PfadDetails = Split(Replace(strPfad, "//", "/"), "/") End Select End If End Function

In die Zelle kommt dann diese Formel:

=PfadDetails(A5)

Wenn wie hier im Beispiel in A5 ein Pfad steht, werden an der Zelle mit der Formel die einzelnen Elemente des Pfades ausgegeben. Das letzte Element sollte bei einem kompletten Pfad zu einer Datei der Dateiname sein.

Das Beispiel mit der Funktion =ZELLE("Dateiname";A1) kann auch als Arrayformel verwendet werden:

Function DateiAusZellFunktion(strFktPfad) Dim arrTemp(1 To 3) Dim Regex As Object, regMatches, regMatch DateiAusZellFunktion = "" If strFktPfad <> "" Then If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "^(.*)\[(.*)\](.*)$" Set regMatches = Regex.Execute(strFktPfad) If regMatches.Count = 1 Then arrTemp(1) = regMatches(0).SubMatches(2) arrTemp(2) = regMatches(0).SubMatches(1) arrTemp(3) = regMatches(0).SubMatches(0) DateiAusZellFunktion = arrTemp End If Set Regex = Nothing End If End Function

In die Zelle kommt dann =DateiAusZellFunktion(ZELLE("Dateiname";A1)) und in ihr sowie den Nachbarzellen werden Blattname, Dateiname und Ordnerpfad erscheinen.

---

Formeln/integrierte Funktionen

Den aktuellen Ordner gibt diese Funktion zurück:

=INFO("Verzeichnis")

---

In anderen Sprachen geht übrigens auch einfach Basename(Pfad).

Zum Verketten von Zeichenfolgen bieten sich zum Beispiel diese Möglichkeiten an:

---

Formeln

="abc " & A1 & "def"

=A20&" "&TEXT(C2; "MM/JJ")

=VERKETTEN(A20;" ";TEXT(C2; "MM/JJ"))

Vorausgesetzt wird, das in C2 das komplette Datum steht. Ansonsten kann die Textformatierung in den Funktionen auch entfallen.

---

Soll ein Datum formatiert verwendet werden, ist das so möglich:

=TEXT(C2;"TT.MM.JJ ")&A1

---

Ein Zeilenumbruch kann so in die Zelle eingefügt werden:

=A1&ZEICHEN(10)&B1&" "&C1&ZEICHEN(10)&D1&ZEICHEN(10)&ZEICHEN(10)&E1&" "&F1

Allerdings ist dies ein zusätzliches Zeichen, was bei etwaigen Textvergleichen berücksichtigt werden muss. In Rohdaten sollte das deshalb vermieden und nur bei der reinen Ausgabe verwendet werden.

---

Ein HTML-Link kann aus den Angaben in Zellen so erstellt werden:

="<a href="&ZEICHEN(34)&B1&ZEICHEN(34)&">"&A1&"</a>"

---

VBA

Zum Ergänzen mehrerer Zellen in einem Bereich ist diese Schleife möglich:

Sub Ergaenzen() Dim rngZelle As Range For Each rngZelle In Range("A1:A10").Cells rngZelle.Value = "abc" & rngZelle.Value & "def" Next End Sub

---

Excel 365: Funktion TEXTVERKETTEN()

Mit dieser Funktion können ganz einfach Texte mit Trennzeichen verkettet werden, wobei die Trennzeichen komplette Strings sein können.

Gibt es zum Beispiel in A1:C5 eine Tabelle, aus der eine HTML-Tabelle erstellt werden soll, kann man einfach in jede Zeile diese Formel eingeben:

="<tr><td>"&TEXTVERKETTEN("</td><td>";;A1:C1)&"</td></tr>"

Zum Schluss gibt man irgendwo diese Formel ein:

="<table>"&TEXTVERKETTEN("";;E1:E5)&"</table>"

Fertig ist die komplette HTML-Tabelle.

Variablennamen müssen mit einem Zeichen des Alphabets beginnen, innerhalb des Gültigkeitsbereichs eindeutig sein, und dürfen nicht länger als 255 Zeichen lang sein.

Jede Variable beansprucht Speicherplatz, was zur Verlängerung der Laufzeit eines Makros (einer Prozedur) führt. Damit sich dies in Grenzen hält, kann man einer Variablen zuweisen, wieviel Speicherplatz sie in Anspruch nimmt, indem man der Variablen einen Datentyp zuweist.

Sie können u. a. als einer der folgenden Datentypen deklariert werden:

• Boolean
• Byte
• Integer
• LongPtr
• String
• Range

Wird kein Datentyp angegeben, so ist der Datentyp Variant standardmä�ig zugewiesen.

Variablen werden gewöhnlich mit der DIM-Anweisung deklariert.

---

Long für 32- und 64-Bit

Statt Long sehen Sie hier LongPtr. Der Grund ist, dass es bei Verwendung von Code mit Long-Variablen in der 64-Bit-Version des Microsoft Office (standardmä�ig wird die 32-Bit-Version installiert) zu Problemen kommen kann: vba-tutorial.de: Datentypen.

Deshalb die Empfehlung: Immer davon ausgehen, dass der Code in beiden Versionen laufen soll und deshalb LongPtr verwenden sowie API-Deklarationen am Anfang des Moduls immer mit einer solchen â??Weicheâ?? vorzunehmen:

#If VBA7 Then Private Declare PtrSafe Function â?¦ (ByRef â?¦ As LongPtr, ByVal â?¦ As LongPtr) As LongPtr #Else Private Declare Function â?¦ (ByRef â?¦ As Long, ByVal â?¦ As Long) As Long #End If

Sie sehen hier einmal das PtrSafe und dass jeder Long-Typ in der aktuellen Version als LongPtr deklariert wurde.

Weitere Beispele:

---

Boolean

Datentypen Boolean werden als 16-Bit-Zahlen (2 Bytes) gespeichert, die nur die Werte True oder False annehmen können.

Bsp:

Sub PruefeZeileOK() Dim bolPositionOK As Boolean If Selection.Row < 10 Then bolPositionOK = False Else bolPositionOK = True If bolPositionOK = False Then MsgBox ("Aktion an dieser Position nicht zulässig!") End Sub

Die folgende Funktion bekommt aus Prozeduren die Zeilenposition übergeben und prüft, ob die Aktion zulässig ist. Rückgabewerte: TRUE oder FALSE

Function PositionOK(lngZeilenposition As Long) As Boolean PositionOK = True If lngZeilenposition < 10 Then PositionOK = False End Function

Die Verwendung in einer Sub könnte dann so aussehen:

Sub Aufruf() Dim lngZeile As LongPtr lngZeile = ActiveCell.Row If PositionOK(lngZeile) = False Then MsgBox "Geht hier nicht, Zeile " & lngZeile & " zu niedrig.", vbOKOnly + vbExclamation, "Fehler" Exit Sub End If End Sub

Byte

Byte werden als einzelne 8-Bit-Zahlen (1 Byte) ohne Vorzeichen gespeichert und haben einen Wert im Bereich von 0 bis 255.

Integer

Integer werden als 16-Bit-Zahlen (2 Bytes) in einem Bereich von -32.768 bis 32.767 gespeichert.

String

Datentyp String kann Buchstaben, Zahlen, Leerzeichen und Satzzeichen enthalten.

Sub Meldung() Dim strText As String Dim strTitel As String strText = "Hallo 12345" strTitel = "*******Titel ******" MsgBox strText, , strTitel End Sub

Range

Datentyp Range gibt eine Zelle oder einen Zellbereich aus.

Sub ZeilenMarkieren() Dim rngBereich As Range Set rngBereich = Sheets("Tabelle1").Range("A1:C5") If rngBereich.Interior.ColorIndex = 3 Then rngBereich.Interior.ColorIndex = 5 Else rngBereich.Interior.ColorIndex = 3 End Sub

Dazu kann man die Funktion ZUFALLSZAHL nutzen. Allerdings liefert sie Zahlen von 0 bis 1, so dass man sich damit behelfen muss:

=GANZZAHL(ZUFALLSZAHL()*(49-1)+1)

Dabei ist 1 die Untergrenze und 49 die Obergrenze.

Für das Datum gibt es nun verschiedene Möglichkeiten. Es kann die Zahl jedes Datums verwendet werden, Bezüge zu Zellen mit den Datumsangaben sind möglich, aber auch die Datumsangaben in Anführungszeichen sind anwendbar:

• =GANZZAHL(ZUFALLSZAHL()*(29221-21916)+21916)
• =GANZZAHL(ZUFALLSZAHL()*(G9-G8)+G8)
• =GANZZAHL(ZUFALLSZAHL()*("01.01.1980"-"01.01.1960")+"01.01.1960")

Ab Excel 365

Hier geht es wesentlich einfacher:

• =ZUFALLSBEREICH("1.1.60";"1.1.80")
• =ZUFALLSBEREICH(I1;I2)
• =ZUFALLSMATRIX(1;1;"1.1.60";"1.1.80";1)
• =ZUFALLSMATRIX(1;1;I1;I2;1)

Angenommen die Datumsangaben stehen in A2:A8:

Datum aufteilen

Die Datumsangaben können mit Formeln auf mehrere Spalten aufgeteilt werden:

• Jahr: =WENN(ISTZAHL(A2);JAHR(A2);"")
• Monat: =WENN(ISTZAHL(A2);MONAT(A2);"")
• Tag: =WENN(ISTZAHL(A2);TAG(A2);"")

AnschlieÃ?end kann ganz normal nach einer der Spalten sortiert werden.

---

Dynamische Arrayfunktion SORTIERENNACH() (ab Excel 365)

Mit dieser Funktion kann das Sortieren in einem Schritt erledigt werden, sie gibt alle Daten auf einmal sortiert aus.

Nach Monat aufsteigend (die 1 steht für aufsteigend):

=SORTIERENNACH(A2:A8;MONAT(A2:A8);1)

Nach Monat und Tag aufsteigend:

=SORTIERENNACH(A2:A8;MONAT(A2:A8);1;TAG(A2:A8);1)

Falls ein gröÃ?erer Bereich in die Funktion eingetragen werden soll, falls zum Beispiel abzusehen ist, dass es mehr Datumsangaben werden, werden auch die noch leeren Zellen ausgegeben. Das sieht nicht schön aus. Dafür kann die Adresse der letzten Zelle mit INDIREKT() â??zusammengebasteltâ?? werden. Hier als Beispiel über die Funktion ANZAHL():

=SORTIERENNACH(INDIREKT("A2:A"&ANZAHL(A2:A15)+1);MONAT(INDIREKT("A2:A"&ANZAHL(A2:A15)+1));1;TAG(INDIREKT("A2:A"&ANZAHL(A2:A15)+1));1)

Hierzu gibt es in Excel eine schöne Funktion: DATEDIF.

Syntax: DATEDIF(Datum1;Datum2;"Parameter")

Das Datum2 mu� grö�er als das Datum1 sein, der Parameter muss immer in "" stehen.

y	Jahre	DATEDIF("01.01.98";"15.02.99";"y")	= 1
m	Monate	DATEDIF("01.01.98";"15.02.99";"m")	= 13
d	Tage	DATEDIF("01.01.98";"15.02.99";"d")	= 410
ym	Monate minus Jahre	DATEDIF("01.01.98";"15.02.99";"ym")	= 1 (13 Monate -1 Jahr (12 Monate))
yd	Tage minus Jahre	DATEDIF("01.01.98";"15.02.99";"yd")	= 45 (410 Tage - 1 Jahr (365 Tage!))
md	Tage minus Monate minus Jahre	DATEDIF("01.01.98";"15.02.99";"md")	= 14 (Differenz vom 01.02. & 15.02))

Das Ergebnis der letzten beiden Beispiele sieht seltsam aus - man beachte aber, dass es sich um die Differenz handelt.

Die Beispiele zeigen, wie die letzte ausgefüllte Zelle zu ermitteln ist. In jedem Fall muss dann nur Zeile oder Spalte um 1 erhöht werden, um auf die erste leere Zelle zu kommen.

VBA

Grundsätzlich:

Mit Cells(Rows.Count, 1).End(xlUp).Row können wir abfragen, welche die letzte ausgefüllte Zelle in Spalte A (also 1) ist.

Brauchen wir die letzte ausgefüllte Zelle in einer Zeile, also die Spaltenangabe dieser Zelle, können wir Cells(1, Columns.Count).End(xlToLeft).Column verwenden (hier für Zeile 1).

---

Diese beiden Codestücke funktionieren auch zuverlässig, wenn nicht gerade die erste Zelle in der Spalte bzw. in der Zeile leer ist. In dem Fall würde auch die 1 zurückgegeben - was hie�e, dass diese erste Zelle Inhalt hätte. Aus diesem Grund muss, wenn dies eine Rolle spielen kann, vorher geprüft werden, ob die erste Zelle der Spalte/Zeile auch leer ist. Damit wird dies berücksichtigt:

Dim strAddr As String 'Spalte A, entspricht 1: If IsEmpty(Cells(1, 1)) Then strAddr = Cells(1, 1).Address Else strAddr = Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Address End If Range(strAddr).Value = "Erste leere Zelle"

Stehen in der ersten Zeile grundsätzlich Spaltenüberschriften, spielt das bei der ersten ausgefüllten Zelle in einer Spalte natürlich keine Rolle.

---

Das Eintragen erfolgt dann einfach in die nächste Zelle. Entweder:

Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Select

oder:

a = Cells(Rows.Count, 2).End(xlUp).Row + 1

Entsprechend ist es auch bei der ersten leeren Zelle in einer Zeile:

a = Cells(2, Columns.Count).End(xlToLeft).Column + 1

Wenn etwas in die erste freie Zelle in einer Zeile kopiert werden soll, kann man z. B. so vorgehen:

Sub NaechstfreieSpalte() Selection.Copy Destination:=Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Offset(0, 1) End Sub

---

Formel

Mit der Funktion ADRESSE() in Verbindung mit ANZAHL2() kann die letzte ausgefüllte Zelle ermittelt werden, wenn sich keine leeren Zellen im Bereich befinden:

=ADRESSE(ANZAHL2(B1:B34)+2;2;4)

Das +2 bedeutet, dass der zu prüfende Bereich erst in B3 beginnt.

Oder:

=INDIREKT("B"&ANZAHL2(B2:B10000)+1)

Das +1 hei�t, dass der erste Wert in B in Zeile 2 steht. Steht der erste Wert in Zeile 1, kann es weggelassen werden. Steht der erste Wert aber in Zeile 3, wäre es +2 usw.

Eine andere Variante, die aber nur bis Spalte Z funktioniert, ist:

=LINKS(ADRESSE(ZEILE($B$6);SPALTE($B$6));3)&ANZAHL2($B$3:$B$65536)+ZEILE($B$3)-1

Am einfachsten geht es sicher mit einem regulären Ausdruck (Microsoft VBScript Regular Expressions-Objektbibliothek kann auch eingebunden werden statt late binding):

Function ErsterBuchstabe(strString As String) Dim Regex As Object, regMatches If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") ErsterBuchstabe = "" Regex.Pattern = "^[^A-Za-z���äöü�]*([A-Za-z���äöü�]).*" Set regMatches = Regex.Execute(strString) If regMatches.Count > 0 Then ErsterBuchstabe = regMatches(0).SubMatches(0) Set Regex = Nothing End Function

In die Zelle: =ErsterBuchstabe(A1).

Die folgende Funktion liefert das erste nichtnumerische Zeichen:

Function ErsteNichtZahl(Zelle) Dim intI As Integer If Len(Zelle) = 0 Then ErsteNichtZahl = "" For intI = 1 To Len(Zelle) If Not IsNumeric(Mid(Zelle, intI, 1)) Then ErsteNichtZahl = Mid(Zelle, intI, 1) Exit Function End If Next End Function

In die Zelle: =ErsteNichtZahl(A1).

Die nächste Funktion liefert den ersten Buchstaben einer Zeichenfolge:

Function ErsterBuchstabe1(Zelle) Dim intI As Integer If Len(Zelle) = 0 Then ErsterBuchstabe = "" For intI = 1 To Len(Zelle) If (Asc(Mid(Zelle, intI, 1)) >= 65 And Asc(Mid(Zelle, intI, 1)) <= 90) Or _ (Asc(Mid(Zelle, intI, 1)) >= 97 And Asc(Mid(Zelle, intI, 1)) <= 122) Or _ Asc(Mid(Zelle, intI, 1)) = 196 Or _ Asc(Mid(Zelle, intI, 1)) = 196 Or _ Asc(Mid(Zelle, intI, 1)) = 214 Or _ Asc(Mid(Zelle, intI, 1)) = 220 Or _ Asc(Mid(Zelle, intI, 1)) = 228 Or _ Asc(Mid(Zelle, intI, 1)) = 246 Or _ Asc(Mid(Zelle, intI, 1)) = 252 Then ErsterBuchstabe = Mid(Zelle, intI, 1) Exit Function Else: ErsterBuchstabe = "" End If Next End Function

In die Zelle: =ErsterBuchstabe(1A1) eingegeben werden.

Dafür gibt es eine weitere Funktion:

=KGRÃ?SSTE(B1:B14;2)

ermittelt den zweithöchsten Wert in B1 bis B14,

=KGRÃ?SSTE(B1:B14;3)

den dritthöchsten.

Dementsprechend funktioniert auch die Funktion KKLEINSTE, sie sucht nach den kleinsten Zahlen.

---

Mit der Funktion FILTER() kann man sich (ab Excel 365) auch gleich die Datensätze ausgeben lassen, die zu den entsprechenden Kriterien passen:

=FILTER(B1:C14;B1:B14=KGRÃ?SSTE(B1:B14;D1))

Zuerst sollte man sich vergewissern, daÃ? C:\Programme\Microsoft Office\Office\Mscal.ocx vorhanden ist (Pfad kann etwas abweichen). Wenn ja, kann man die Datei mit dem folgenden Makro registrieren lassen:

Diese Zeile mu� im Modul ganz oben stehen: Declare Function DllRegisterServer Lib "mscal.ocx" () As Long 'Dieses Makro ausführen: Sub anmelden() DllRegisterServer End Sub

Das Makro mu� dabei ganz oben in einem allgemeinen Modul stehen. Sollte das nicht funktionieren, kopiert man die mscal.ocx in das Windows/System-Verzeichnis und führt das Makro erneut aus. In jedem Fall mu� zumindest Excel nach dem Registrieren neu gestartet werden, wenn nicht gar Windows.

Wichtig: Man sollte damit aber vorsichtig sein, wenn man VBA-Anwendungen für Andere erstellt. Denn dort ist die ocx erstmal nicht vorhanden und mu� demzufolge erstellt werden. D. h., wenn man den Kalender verwendet, mu� er auf anderen Computern nicht unbedingt laufen.

Hinweis:

Falls Sie unabhängig von den vorgegebenen Steuerelementen sein möchten, können Sie sich auch an mich wenden. Ich kann Ihnen ein Steuerelement mit Schnittstellen zu Ihrer Anwendung zur Verfügung stellen.

Excel-Kommunikator: Chat und E-Mail per Excel

Das Add-In ist der Nachfolger des Mail-Add-Ins, an dem immer wieder Interesse bestand. Allerdings war es mit der Zeit veraltet, so dass eine komplette Neuentwicklung langsam überfällig war. Das hier vorgestellte Add-In sollte ab der Version 2007 funktionieren - Nutzer des alten Add-Ins finden hier nur eine andere (und umfangreichere) Bedienung; die alten Daten können mit der gleichen Syntax übernommen werden.

---

JL-Chat JL-Mail Backup/Restore Technik, Datenschutz Kosten

Basis ist ein eigener Nick, der frei gewählt werden kann, jedoch insgesamt nur einmal vorkommen darf. Nach Gro�-/Kleinschreibung wird dabei unterschieden. Dieser Nick muss einmalig im System registriert werden, danach erfolgt die Kommunikation pro Add-In immer mit diesem Nick. Jeder Teilnehmer sieht Sie dann also unter diesem Namen. Die Absenderangaben bei Mails können natürlich unabhängig davon verwendet werden, so dass ein Empfänger Ihren richtigen Namen sieht, wenn Sie diesen beim Mailversand angeben.

---

Chat

Eigener Nickname

Gruppen

Posten und Listenanzeige

Zellen und Bereiche posten

Ausgaben

Neue Nachrichten

---

Mail

Absender

Empfänger

Mailtext, Anhang

Versand

---

Backup und Restore

Backup

Restore

Bei einer leeren Add-In-Datei, wenn also noch kein Nick vergeben ist, ist der Button »Restore« statt des Buttons zur Sicherung sichtbar. Nach dem Anklicken erscheint ein Dialog zum Eingeben des Nicknamens und des Kennworts, das Sie beim ersten Erstellen vergeben haben. Stimmen diese Daten, werden die Daten aus dem letzten Backup in das Add-In eingetragen und es stehen alle Funktionen/Daten wie beim Zeitpunkt des Erstellens des Backups zur Verfügung.

---

Technik, Ausschlüsse und Datenschutz

Da die Daten entfernten Empfängern zur Verfügung gestellt werden, müssen sie natürlich auch irgendwo gespeichert werden. Dies erfolgt auf dem Server joerglorenz.de in einer MySQL-Datenbank, die auf dem aktuellen Stand der Technik abgesichert ist. Au�er mir, dem Autor des Add-Ins, hat niemand Zugriff darauf.

Gespeichert werden nur die Daten, die den Absendern und den Empfängern vorgehalten werden müssen - also all das, was Sie über die Felder im Menüband eingeben. Dateien als Mailanhänge werden auf dem Server nur bis zum letztendlichen Versand der Mail gespeichert und anschlie�end gleich wieder gelöscht. Da das ganze System über Nicknamen läuft, werden auch keine sonstigen personenbezogenen Daten gespeichert - natürlich mit Ausnahme derer, die Sie selbst in den Eingabefeldern/Messages eintragen.

Es wird zugesichert, dass Ihre Daten nur zum eigentlichen Zweck Ihrer Kommunikation gespeichert werden und sonst in keiner Weise verwendet oder überwacht werden. Au�er natürlich, wenn ich selbst davon nichts wei� - ausschlie�en kann man ja leider nichts.

Sollen bestimmte Daten gelöscht werden, wenden Sie sich bitte einfach mit Angabe des Nicknamens an mich.

Verboten sind generell Texte, die gegen Recht und Gesetz versto�en, aber auch fanatische und insbesondere rechte bzw. fremdenfeindliche Inhalte. Sollten solche Texte bemerkt werden, wenden Sie sich bitte an mich. Diese werden dann durch mich unverzüglich gelöscht.

---

Kosten

Dieses Add-In kann leider nicht kostenlos angeboten werden. Sie haben die Möglichkeit, 50 Postings abzusetzen und 50 Mails (an mehrere Empfänger gilt als eine Mail) zu versenden. Eine weitere Nutzung ist dann für 10,00 � pro Add-In (also pro Nick) möglich. Bei Nutzung in Gruppen (Unternehmen, Vereine usw.) kann es verschiedene Ermä�igungen geben, wenn mir eine Liste der zugehörigen Nicks überlassen wird.

Bei Angabe einer Rechnungsanschrift erhalten Sie natürlich in jedem Fall eine absetzbare Rechnung.

Perspektivisch wird das Add-In um weitere Funktionen ergänzt. Diese Erweiterungen sind dann natürlich im Preis bereits enthalten.

Download: excelkomm.xlam

Ab Excel 365 kann einfach die Funktion verwendet werden:

=FORMELTEXT(K3)

Die Formel mit dieser Funktion gibt die Formel zurück, die in K3 steht.

---

Für ältere Versionen kann die benutzerdefinierte Funktion verwendet werden:

Prüfen, ob in der Zelle eine Formel vorliegt und anschlie�end die Formel (ohne Gleichheitszeichen) mit dem Ergebnis ausgeben lassen:

Function Bezug(Zelle) If Zelle.HasFormula Then Bezug = Right(Zelle.Formula, Len(Zelle.Formula) - 1) & " = " & Zelle Else Bezug = "" End Function

In die Zelle kommt dann einfach die Formel =Bezug(D7), wobei hier in D7 die eigentliche Formel steht.

Zelle:	B7	C7	D7	E7
enthält:	10	15	=B7+C7*2	=Bezug(D7)
Ergebnis:			40	B7+C7*2 = 40

---

Noch eine benutzerdefinierte Funktion dazu, die einfach das Gleichheitszeichen ersetzt (also löscht):

Function Bezug1(Zelle) If Zelle.HasFormula Then Bezug = Replace(Zelle.FormulaLocal, "=", "") Else Bezug = "" End If End Function

In die Zelle kann dann z. B. eingegeben werden: =Bezug1(A1)

---

Oder für die Freunde gepflegter regulärer Ausdrücke (Microsoft VBScript Regular Expressions-Objektbibliothek muss eingebunden sein!):

Function Bezug2(Zelle) Dim Regex As New RegExp, regMatches As MatchCollection, regMatch As Match Bezug1 = 0 Regex.Pattern = "^(=)(.*)$" Set regMatches = Regex.Execute(Zelle.FormulaLocal) If regMatches.Count > 0 Then Bezug1 = regMatches(0).SubMatches(1) End Function

Alternativ geht es auch mit der Tastenkombination Strg und ` (Graviszeichen, Taste rechts neben � mit Umschalttaste drücken).

Sollen nur ausgewählte Formeln gedruckt werden, kann man als erstes in die Zelle ein Hochkomma (') eingeben, dann wird der Inhalt der Zelle als Text behandelt. Das empfiehlt sich übrigens auch dann, wenn eine längere Formel nicht beendet ist, aber die Mappe geschlossen werden soll.

Ab Excel 365

Sollen die Formeln zusätzlich zu den Ergebnissen gedruckt werden, können die mit der Funktion FORMELTEXT() angezeigt werden:

=FORMELTEXT(A1)

Dafür gibt es verschiedene Möglichkeiten - wobei es mit der Find-Methode Probleme gibt, da die nach dem Datum sucht, nicht aber nach einem Teil davon. Gezeigt werden zwei Möglichkeiten - die erste funktioniert ab Excel 365, die zweite generell:

---

Einsatz der Tabellenfunktion FILTER() ab Excel 365

Sub Geburtstage1() Dim lngLZ As LongPtr Dim intN As Integer Dim strEintrag As String Dim wksBlatt As Worksheet Dim arrS(), lngArrS As LongPtr Dim varT lngArrS = -1 For Each wksBlatt In ActiveWorkbook.Sheets lngLZ = wksBlatt.Cells(wksBlatt.Rows.Count, 4).End(xlUp).Row varT = Application.Evaluate("=FILTER(" & wksBlatt.Name & "!C3:J" & lngLZ & ",(DAY(" & wksBlatt.Name & "!F3:F" & lngLZ & ")=DAY(TODAY()))*(MONTH(" & wksBlatt.Name & "!F3:F" & lngLZ & ")=MONTH(TODAY())),0)") If IsArray(varT) Then For intN = 1 To UBound(varT) lngArrS = lngArrS + 1 ReDim Preserve arrS(lngArrS) strEintrag = Format(varT(intN, 4), "DD.MM.YYYY") & " " strEintrag = strEintrag & Format(Year(Date) - Year(varT(intN, 4)), "00") & " " strEintrag = strEintrag & varT(intN, 3) & ", " & varT(intN, 2) strEintrag = strEintrag & ", Telefon: " & varT(intN, 8) strEintrag = strEintrag & " (Blatt: " & wksBlatt.Name & ")" arrS(lngArrS) = strEintrag Next End If Next UserForm1.ListBox1.List = arrS UserForm1.Show End Sub

---

Alte Variante, generell funktionshähig

Hier wird das Verwenden einer Schleife aufgezeigt.

Dazu wird natürlich eine Userform benötigt, hier ist es UserForm1. Auf ihr sind die ListBox1 und ein Commandbutton zum Schlie�en der Userform.

Die folgende Routine, die hier in einem Standardmodul sein muss, durchläuft alle Blätter und prüft in Spalte 6 (F) auf Datumsangaben. Wenn es sich um ein Datum handelt, wird auf �bereinstimmung mit dem heutigen Tag und dem heutigen Monat geprüft. Gibt es die, wird in diesem Beispiel einfach ein String aus den Angaben gebastelt und in einen Array aufgenommen.

Am Ende wird der Array mit UserForm1.ListBox1.List an die Listbox übergeben und die Userform aufgerufen.

Sub Geburtstage() Dim lngEZ As LongPtr, lngLZ As LongPtr, lngZ As LongPtr, lngS As LongPtr Dim strEintrag As String Dim wksBlatt As Worksheet Dim arrS(), lngArrS As LongPtr lngS = 6 lngArrS = -1 For Each wksBlatt In ActiveWorkbook.Sheets lngEZ = wksBlatt.UsedRange.Row lngLZ = lngEZ + wksBlatt.UsedRange.Rows.Count If lngLZ > lngEZ Then With wksBlatt For lngZ = lngEZ To lngLZ If IsDate(.Cells(lngZ, lngS)) Then If Day(.Cells(lngZ, lngS)) = Day(Date) And Month(.Cells(lngZ, lngS)) = Month(Date) Then lngArrS = lngArrS + 1 ReDim Preserve arrS(lngArrS) strEintrag = .Cells(lngZ, 6).Text & " " strEintrag = strEintrag & Format(Year(Date) - Year(.Cells(lngZ, 6)), "00") & " " strEintrag = strEintrag & .Cells(lngZ, 5) & ", " & .Cells(lngZ, 4) strEintrag = strEintrag & ", Telefon: " & .Cells(lngZ, 10) strEintrag = strEintrag & " (Blatt: " & .Name & ")" arrS(lngArrS) = strEintrag End If End If Next End With End If Next UserForm1.ListBox1.List = arrS UserForm1.Show End Sub

Es gibt natürlich auch Alternativen. So kann z. B. der Array mehrspaltig verwendet und das Ganze zu einer Funktion umgeschrieben werden, die den Array zurückgibt und beliebig eingesetzt werden kann. Oder die Listbox wird mit ColumnCount mehrspaltig erstellt und die einzelnen Daten werden auf mehrere Spalten verteilt. Oder die Daten werden sofort in die Listbox geschrieben. Oder, oder, oder �

Soll die Geburtstagsprüfung beim Dateiaufruf erfolgen, wird im Klassenmodul DieseArbeitsmappe (doppelt anklicken) dieser Code eingefügt:

Private Sub Workbook_Open() Geburtstage End Sub

Damit der Commandbutton wirkt: Doppelklick auf den Button und diesen Code eintragen:

Private Sub CommandButton1_Click() Unload Me End Sub

imageMSO-Galerie

Die Symbole sind in einer einheitlichen GröÃ?e dargestellt. An der Schärfe erkennt man allerdings bereits, ob sie für â??largeâ??- oder â??normalâ??-Steuerelemente verwendet werden können.

Nach dem Anklicken eines Symbols erscheint rechts auf einem Button die Vergrö�erung und in einer Textbox der Code, der im XML verwendet werden kann. Rechts anklicken, kopieren und einfügen.

Das Add-In sollte ab Excel 2010 funktionieren. Es kann frei genutzt, darf aber nicht geändert werden.

Download: imagemso.xlam

Excel-Player

Wahlweise kann ein kleines Videofenster eingeblendet werden, das generell im Vordergrund ist - also auch bei der Arbeit in anderen Programmen. Ist das Videofenster ausgeblendet, können Sie einfach den Ton hören.

Ein kleines Videofenster kann eingeblendet werden, sonst ist nur der Ton zu hören. Das Videofenster ist verschiebbar, so dass es bei der Arbeit in Excel nicht stört.
 

Das Add-In sollte ab Excel 2007 funktionieren. Es kann frei genutzt, darf aber nicht geändert werden. Beim Aufruf erscheint ein Werbefenster. Gegen eine Gebühr von 5,00 � erhalten Sie einen Freischaltcode, so dass das Add-In in der Folge werbefrei ist.

Download: excelplayer.xlam

In Zeiten zunehmender Vernetzung spielt natürlich auch das Json-Format eine gro�e Rolle, zunehmend auch für Excel. Das Senden und Empfangen der Daten ist kein Problem, während die Analyse dieser Daten mit VBA vergleichsweise umständlich ist. Einfache Möglichkeiten, wie beispielsweise mit jQuery, geben die Bordmittel von VBA nicht her.

Wesentlich vereinfacht wird dies jedoch mit dem JsonConverter von Tim Hall, den es hier zum Download gibt: VBA-tools/VBA-JSON. Zur Installation müssen (alles für Windows) nur zwei Schritte erfolgen:

• Modul JsonConverter.bas in das VBA-Projekt einfügen
• im Editor unter Extras ▸ Verweise ein Häkchen bei Microsoft Scripting Runtime setzen

Damit steht schon die Funktion JsonConverter.ParseJson() zur Verfügung.

Eine Datenebene

Das Verwenden soll hier zunächst an einem einfachen Beispiel gezeigt werden. Dazu nutzen wir dieses PHP-Script, das einen Adressdatensatz als Json-Objekt zur Verfügung stellt, den wir mit VBA abrufen:

$a['vorname'] = "Max"; $a['nachname'] = "Mütze"; $a['strasse'] = "Mützenweg 55"; $a['plz'] = "01234"; $a['ort'] = "Mützenhausen"; echo json_encode($a);

Zunächst rufen wir das Ganze vom Server ab:

strURL = "https://example.org/jsonabfrage.php" strPostDaten = "" 'Hier käme etwas rein, wenn was an den Server übermittelt werden sollte With CreateObject("MSXML2.XMLHTTP") .Open "POST", strURL, False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .Send (strPostDaten)

Damit empfangen wir .ResponseText. Zum Vermeiden von Fehlern durch den JsonConverter ist hier schon wichtig, diese Rückgabe zu prüfen. Im einfachsten Fall mit If InStr(1, .ResponseText, "{") > 0 Then.

In .ResponseText steckt nun dieses Objekt:

Das weisen wir mit der Funktion JsonConverter.ParseJson(.ResponseText) einer Variablen zu, die als Dictionary-Objekt deklariert ist:

Set dicParsed = JsonConverter.ParseJson(.ResponseText)

In der Variablen sind nun die einzelnen Einträge aus dem ResponseText als Key=Value-Paare enthalten. Da die Variable dicParsed ein Objekt ist, verfügt sie über verschiedene Eigenschaften, mit denen wir arbeiten können. So können wir z. B. einfach eine Schleife über die Keys laufen lassen und haben somit deren Werte:

strAusgabe = strAusgabe & dicParsed.Count & " Einträge:" & vbNewLine & vbNewLine For Each varWert In dicParsed.Keys strAusgabe = strAusgabe & varWert & ": " & dicParsed(varWert) & vbNewLine Next varWert MsgBox strAusgabe

Das komplette VBA-Script zum Testen:

Sub Post_JSONAusgabe_1() Dim strURL As String, strPostDaten As String Dim dicParsed As Dictionary Dim varWert As Variant, strAusgabe As String strURL = "https://example.org/jsonabfrage.php" strPostDaten = "" 'Hier käme etwas rein, wenn was an den Server übermittelt werden sollte With CreateObject("MSXML2.XMLHTTP") .Open "POST", strURL, False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .Send (strPostDaten) 'Die Antwort muss geprüft werden, da sonst ein Fehler beim JsonConverter auftritt. 'Hier einfach auf das Vorhandensein der geschweiften Klammer: If InStr(1, .ResponseText, "{") > 0 Then strAusgabe = "" Set dicParsed = JsonConverter.ParseJson(.ResponseText) strAusgabe = strAusgabe & dicParsed.Count & " Einträge:" & vbNewLine & vbNewLine For Each varWert In dicParsed.Keys strAusgabe = strAusgabe & varWert & ": " & dicParsed(varWert) & vbNewLine Next varWert MsgBox strAusgabe Else MsgBox "Schiefgegangen: " & .ResponseText, vbOKOnly + vbCritical, "Fehler" End If End With End Sub

 

Mehrere Datenebenen

Häufig haben wir es jedoch mit Verschachtelungen zu tun, dass also in einem Array-Element ein weiterer Array (bzw. in einem Json-Element ein weiteres Json-Objekt) steckt. im vorigen Beispiel waren alle Elemente auf einer Ebene, aber genau so könnten die Elemente insgesamt ein Wert eines übergeordneten Elements sein:

• values
  • vorname="Max"
  • nachname="Mütze"
  • strasse="Mützenweg 55"
  • plz="01234"
  • ort="Mützenhausen"

Wir hätten hier also den Key â??valuesâ??, dem als Wert ein weiterer Array, bestehend aus Key-Value-Paaren, zugeordnet ist. Ein Beispiel, wie dies mit PHP möglich wäre:

$a['vorname'] = "Max"; $a['nachname'] = "Mütze"; $a['strasse'] = "Mützenweg 55"; $a['plz'] = "01234"; $a['ort'] = "Mützenhausen"; $b['values'] = $a; echo json_encode($b);

In VBA würde somit dieses Json-Objekt ankommen:

Zum Dekodieren verwenden wir wieder die bekannte Funktion und weisen das Ganze der Dictionary-Variablen zu:

Set dicParsed = JsonConverter.ParseJson(.ResponseText)

Wenn wir nun an die relevanten Inhalte wollen, müssen wir beachten, dass die als Array (bzw. genauer als Dictionary) im übergeordneten Schlüssel â??valuesâ?? stecken. Das heiÃ?t, dass wir den ansprechen müssen. Wir durchlaufen also die einzelnen Elemente in dicParsed("values"):

'Hier werden nur die Einträge aus â??valuesâ?? verwendet, also das, was in PHP in $a steckt: For Each varWert In dicParsed("values").Keys strAusgabe = strAusgabe & varWert & ": " & dicParsed("values")(varWert) & vbNewLine Next varWert

Hier ist das gesamte Script zum Testen, zum Schluss ergänzt um ein paar Ausgaben zur Verdeutlichung:

Sub Post_JSONAusgabe_2() 'PHP: 'Beachten: Hier gibt es eine Verschachtelung. 'Im Array $a sind die eigentlichen Daten enthalten. '$a['vorname'] = "Max"; '$a['nachname'] = "Mütze"; '$a['strasse'] = "Mützenweg 55"; '$a['plz'] = "01234"; '$a['ort'] = "Mützenhausen"; 'Zuletzt wird $a jedoch dem Array $b zugewiesen, hier dem Key â??valuesâ??: '$b['values'] = $a; 'Im Json ist also diese Verschachtelung auch enthalten und wird so ausgegeben: 'echo json_encode($b); Dim strURL As String, strPostDaten As String Dim dicParsed As Dictionary Dim varWert As Variant, strAusgabe As String strURL = "https://example.org/jsonabfrage.php" strPostDaten = "" With CreateObject("MSXML2.XMLHTTP") .Open "POST", strURL, False .setRequestHeader "Content-Type", "application/x-www-form-urlencoded" .Send (strPostDaten) If .ResponseText <> "" Then 'Anpassen, auf Fehler prüfen! strAusgabe = "" 'dicParsed ist der komplette(!) verschachtelte Array: Set dicParsed = JsonConverter.ParseJson(.ResponseText) 'Hier werden nur die Einträge aus â??valuesâ?? verwendet, also das, was in PHP in $a steckt: For Each varWert In dicParsed("values").Keys strAusgabe = strAusgabe & varWert & ": " & dicParsed("values")(varWert) & vbNewLine Next varWert MsgBox "In PHP in $a enthalten:" & vbNewLine & vbNewLine & strAusgabe 'Nun wird der Array um einen Eintrag erweitert (entspräche in PHP $a['alter'] = 32;): 'dicParsed("values")("alter") = 32 dicParsed("values").Add "alter", 32 strAusgabe = "Das gesamte Json-Objekt ist nun:" & vbNewLine & vbNewLine strAusgabe = strAusgabe & JsonConverter.ConvertToJson(dicParsed) 'komplettes Json-Objekt strAusgabe = strAusgabe & vbNewLine & vbNewLine strAusgabe = strAusgabe & "während im Key â??valuesâ?? (ehemals $b) nur das enthalten ist:" & vbNewLine & vbNewLine strAusgabe = strAusgabe & JsonConverter.ConvertToJson(dicParsed("values")) 'Inhalt nur von "values" MsgBox strAusgabe Else MsgBox "Schiefgegangen.", vbOKOnly + vbCritical, "Fehler" End If End With End Sub

Download: excel_php_json.xlsm

Formeln

Am einfachsten gehte s sicher so:

=ISOKALENDERWOCHE(A2)

=KALENDERWOCHE(A2;2)

�brigens können (ab Excel 365) mit nur einer einzigen Formel alle Tage eines Jahres mit Kalenderwochen und Wochentagen (und was auch immer) angezeigt werden:

=TEXT(SEQUENZ(TAGE("31.12."&F1;"1.1."&F1)+1;1;"1.1."&F1;1);"TT.MM.JJJJ")&" (KW "&TEXT(ISOKALENDERWOCHE(SEQUENZ(TAGE("31.12."&F1;"1.1."&F1)+1;1;"1.1."&F1;1));"00")&" "&TEXT(SEQUENZ(TAGE("31.12."&F1;"1.1."&F1)+1;1;"1.1."&F1;1);"TTT")&")"

---

UDF - benutzerdefinierte Funktionen

Früher, als es die schönen Excelfunktionen noch nicht gab, musste man sich damit behelfen:

Diese Funktion stammt von Christoph Kremer:

Function DINKwoche(Datum) Dim tmp tmp = DateSerial(Year(Datum + (8 - WeekDay(Datum)) Mod 7 - 3), 1, 1) DINKwoche = ((Datum - tmp - 3 + (WeekDay(tmp) + 1) Mod 7)) \ 7 + 1 End Function

Zweite Möglichkeit:

Function kw(Datum As Date) As Single kw = Format(Datum, "ww", , vbFirstFourDays) - IIf(Weekday(Datum) = 1, 1, 0) End Function

Einige alte Beispiele auf diesen Seiten basieren noch auf diesen Berechnungen.

Drei Varianten:

Namen zählen ab Excel 365: dynamische Arrayformeln

Sub Namen_Zaehlen() Dim intN As Integer Dim rngZelle As Range Dim arrTemp Dim arrSammler(), lngArrSammler As Long intN = 0 lngArrSammler = 0 For Each rngZelle In Range("A1:B4").Cells arrTemp = Split(rngZelle, ", ") If UBound(arrTemp) > -1 Then For intN = 0 To UBound(arrTemp) lngArrSammler = lngArrSammler + 1 ReDim Preserve arrSammler(1 To lngArrSammler) arrSammler(lngArrSammler) = Trim(arrTemp(intN)) Next End If Next MsgBox UBound(Application.WorksheetFunction.Unique(arrSammler, 1)) End Sub

---

Namen ausgeben ab Excel 365: dynamische Arrayformeln als Matrixfunktion

Function Einzelnamen(ByRef rngRange As Range) Dim intN As Integer Dim rngZelle As Range Dim arrTemp Dim arrSammler(), lngArrSammler As Long intN = 0 lngArrSammler = 0 For Each rngZelle In rngRange.Cells arrTemp = Split(rngZelle, ", ") If UBound(arrTemp) > -1 Then For intN = 0 To UBound(arrTemp) lngArrSammler = lngArrSammler + 1 ReDim Preserve arrSammler(1 To lngArrSammler) arrSammler(lngArrSammler) = Trim(arrTemp(intN)) Next End If Next Einzelnamen = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Unique(arrSammler, 1)) End Function

In die Zelle kann dann einfach die Formel:

=Einzelnamen(A1:B8)

---

Variante für ältere Versionen

'An den Anfang des Moduls: Dim arrSammler(), lngArrSammler As Long Sub Auswerten() Dim intN As Integer, intZ As Integer Dim rngZelle As Range Dim arrTemp intN = 0 lngArrSammler = -1 For Each rngZelle In Range("A1:B4").Cells arrTemp = Split(rngZelle, ",") If UBound(arrTemp) > -1 Then For intN = 0 To UBound(arrTemp) Sammler arrTemp(intN) Next End If Next lngArrSammler = lngArrSammler + 1 MsgBox lngArrSammler End Sub Function Sammler(ByVal strName As String) Dim lngZ As Long, strTemp As String strTemp = LCase(Trim(strName)) If lngArrSammler >= 0 Then For lngZ = 0 To lngArrSammler If LCase(arrSammler(lngZ)) = strTemp Then Exit Function Next End If lngArrSammler = lngArrSammler + 1 ReDim Preserve arrSammler(lngArrSammler) arrSammler(lngArrSammler) = Trim(strName) End Function

Die Funktion prüft nur, ob der aktuelle Name bereits im Array ist und erweitert den Array. Geschmacksache - das kann natürlich auch in die eigentliche Routine.

SVERWEIS

MIt SVERWEIS lassen wir in Spalte A nach dem Namen suchen, als Spaltenindex nehmen wir die Funktion VERGLEICH():

=SVERWEIS(A10;A2:M5;VERGLEICH(B10;B1:M1;0)+1)

Damit erhalten wir die Zahl im Schnittpunkt des ersten Treffers in Zeile 3, was hier die Zahl 22 ist.

Dynamische Arrayfunktion FILTER() (ab Excel 365)

Allerdings gibt es noch weitere mögliche Schnittpunkte, denn sowohl der Name als auch der Monat sind zweimal enthalten. Das wäre insgesamt vier Schnittpunkte.

Mit FILTER(B2:M6;A2:A6=A10;"") erhalten wir alle Daten der Tabelle, bei denen in Spalte A der zu suchende Name steht - allerdings nur die beiden Zeilen. Wir haben also eine Matrix bzw. einen Array, die/der aus zwei Zeilen zu jeweils 12 Zahlen besteht.

Aus diesem Array lassen wir mit einem zusätzlichen Filter die Spalten filtern, die auf den zu suchenden Monat zutreffen. Dazu nehmen wir wieder die Filter-Funktion und verwenden dort als Matrix das Ergebnis der ersten Filter-Funktion:

=FILTER(FILTER(B2:M6;A2:A6=A10;"");B1:M1=B10;"")

Als Ergebnis dieser Formel haben wir nun die vier Schnittpunkte, wie es im Beispiel zu sehen ist.

Mit dem Schnittmengenoperator @ können wir - wenn gewünscht - festlegen, dass das Verhalten wie beim SVERWEIS ist, dass also nur das erste Ergebnis angezeigt wird. Dazu fügen wir das @-Zeichen nach dem Gleichheitszeichen ein:

=@FILTER(FILTER(B2:M6;A2:A6=A10;"");B1:M1=B10;"")

Die Aufgabenstellung, per Mausklick oder automatisiert Mails zu versenden, ist sehr weit verbreitet. Es gibt auch viele Tipps, wie das mit Outlook erfolgen kann. Jedoch gibt es immer wieder Probleme, sei es durch Rechtebeschränkungen, wegzuklickende Meldungen von Outlook usw.

Am sinnvollsten ist deshalb eine Lösung, mit der man weitestgehend unabhängig von Officeprogrammen ist. Hier besteht die Möglichkeit, VBA nur zum Versand der Maildaten an einen Server zu benötigen, der dann den Rest des Erstellens und Versands der Mail übernimmt.

Voraussetzung für dieses Beispiel ist, dass auf dem Server ein eigenes PHP-Script erstellt werden kann, das dann natürlich auch eine Adresse (URL) hat.

Basis ist der Beitrag Dateiupload. Der VBA-Code dazu wurde hier um die Möglichkeit, Text zu versenden, erweitert. Prinzipiell trifft hier aber das Gleiche zu - vor allem, dass die oben verwendeten Konstanten auch dynamisch verwendet werden können. Hier wird nur das Prinzip aufgezeigt, die Anpassungen müssen dann entsprechend der eigenen Gegebenheiten erfolgen. Dies betrifft insbesondere auch die Sicherheit. Denken Sie daran, die manuell zu ändernden Daten vorher zu prüfen. Diese Scripte sind auch leicht zum Versand von Massenspam zu verwenden.

Dies ist der VBA-Code, der um die Text-Funktion erweitert wurde:

Private Const strURL As String = "https://�Ihre URL�/�Ihre PHP-Datei�.php" Private Const strDatei1 As String = "C:\�\test1.jpg" Private Const strDatei2 As String = "C:\�\test2.jpg" Private Const strDatei3 As String = "C:\�\test3.jpg" Private Const strMailEmpfaenger As String = "info1@example.org;info2@example.org;info3@example.org" Private Const strAbsText As String = "Max Mütze" Private Const strAbsMail As String = "xyz@example.org" Private Const strBoundary As String = "---------------------------7da24f2e50046" Sub DateiUploadUndMail() Dim strPostDaten As String strPostDaten = "" strPostDaten = strPostDaten & Header_Text("empfaenger", strMailEmpfaenger, "text/plain", strBoundary) strPostDaten = strPostDaten & Header_Text("abstext", strAbsText, "text/plain", strBoundary) strPostDaten = strPostDaten & Header_Text("absmail", strAbsMail, "text/plain", strBoundary) strPostDaten = strPostDaten & Header_Text("betreff", "Das ist der Betreff.", "text/plain", strBoundary) strPostDaten = strPostDaten & Header_Text("mailtext", "Hallo!" & vbNewLine & vbNewLine & "Ich bin der Mailtext.", "text/html", strBoundary) strPostDaten = strPostDaten & Header_Datei(strDatei1, strBoundary) strPostDaten = strPostDaten & Header_Datei(strDatei2, strBoundary) strPostDaten = strPostDaten & Header_Datei(strDatei3, strBoundary) strPostDaten = strPostDaten & "--" & strBoundary & "--" With CreateObject("Microsoft.XMLHTTP") .Open "POST", strURL, False .SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & strBoundary .Send SendDaten(strPostDaten) MsgBox .ResponseText End With End Sub Function Header_Text(strKey As String, strValue As String, strMime As String, strBoundary) Header_Text = "--" & strBoundary & vbCrLf & _ "Content-Disposition: form-data; name=""" & strKey & """;" & vbCrLf & _ "Content-Type: " & strMime & "; charset=UTF-8" & vbCrLf & vbCrLf & strValue & vbCrLf End Function Function Header_Datei(strDateiPfad As String, strBoundary As String) Dim strDateiKonv As String, strDateiName As String Header_Datei = "" If strDateiPfad <> "" Then strDateiName = DateiName(strDateiPfad) strDateiKonv = DateiKonv(strDateiPfad) Header_Datei = "--" & strBoundary & vbCrLf & _ "Content-Disposition: form-data; name=""file[]""; filename=""" & strDateiName & """" & vbCrLf & _ "Content-Type: application/octet-stream" & vbCrLf & vbCrLf & strDateiKonv & vbCrLf End If End Function Function DateiName(strpfad As String) DateiName = "" If strpfad <> "" Then DateiName = Mid$(strpfad, InStrRev(strpfad, "\") + 1) End Function Function DateiKonv(strpfad As String) Dim lngDNr As LongPtr, bytBuffer() As Byte DateiKonv = "" lngDNr = FreeFile Open strpfad For Binary Access Read As lngDNr If LOF(lngDNr) > 0 Then ReDim bytBuffer(0 To LOF(lngDNr) - 1) As Byte Get lngDNr, , bytBuffer DateiKonv = StrConv(bytBuffer, vbUnicode) End If Close lngDNr End Function Private Function SendDaten(strText As String) As Byte() SendDaten = StrConv(strText, vbFromUnicode) End Function

Damit werden die Daten an das PHP-Script gesendet, das diese empfängt und daraus die Mails erstellt sowie diese versendet. Auch hier unbedingt daran denken, die Daten noch auf Gültigkeit zu prüfen!

Das komplette PHP-Script:

/* Wichtig: Da das Script prinzipiell auch zu Versand von Massenspam geeignet ist, sollten ganz am Anfang noch Kennwort und Nutzername (oder eine andere Absicherung) abgefragt werden. Diese Angaben können von VBA aus ganz einfach als POST-Paare mitgeschickt werden. */ // Verzeichnis, in dem die Anhänge zwischengespeichert werden: $anhangverz = 'uploadtest/'; // Vorsicht: Ggf. prüfen, ob vorhanden und leer. // Mailadressen durch Semikolon getrennt $empfstrings = $_POST['empfaenger']; // Text, der als Absender erscheint: $abstext = $_POST['abstext']; // Mailadresse des Absenders: $absmail = $_POST['absmail']; $betreff = utf8_encode($_POST['betreff']); $mailtext = utf8_encode($_POST['mailtext']); // File[]-Array sinnvoll sortieren: $dateiarray = array(); foreach($_FILES['file'] as $k1 => $v1) { foreach($v1 as $k2 => $v2) { $dateiarray[$k2][$k1] = $v2; } } // Anhänge speichern, Daten für Versand aufbereiten $anhangarray = array(); $a = 0; foreach ($dateiarray as $file) { // Ggf. prüfen, ob Dateiname schon im Verzeichnis vorhanden ist und // ggf. umbenennen: $datname = basename($file['name']); $uploadpfad = $anhangverz . $datname; if (move_uploaded_file($file['tmp_name'], $uploadpfad)) { $a++; $anhangarray[$a]['pfad'] = $uploadpfad; $anhangarray[$a]['dateiname'] = $datname; $anhangarray[$a]['groesse'] = filesize($uploadpfad); $dateiinhalt = fread(fopen($uploadpfad, "r"), filesize($uploadpfad)); $anhangarray[$a]['data'] = chunk_split(base64_encode($dateiinhalt)); } } $empf_array = explode(";",$empfstrings); $encoding = mb_detect_encoding($mailtext, "utf-8, iso-8859-1, cp-1252"); $mime_boundary = "-----=" . md5(uniqid(microtime(), true)); $versendet = 0; // Mail an jeden Empfänger schicken: foreach($empf_array as $einzelmail) { if (trim($einzelmail) != "") { $header ="From:" . $abstext . "<" . $absmail . ">\n"; $header.= "MIME-Version: 1.0\r\n"; $header.= "Content-Type: multipart/mixed;\r\n"; $header.= " boundary=\"" . $mime_boundary . "\"\r\n"; $content = "This is a multi-part message in MIME format.\r\n\r\n"; $content.= "--".$mime_boundary."\r\n"; $content.= "Content-Type: text/plain; charset=\"$encoding\"\r\n"; $content.= "Content-Transfer-Encoding: 8bit\r\n\r\n"; $content.= $mailtext . "\r\n"; if ($a > 0) { // Ggf. Mailanhänge anfügen for ( $n = 1; $n <= $a; $n++) { $content.= "--" . $mime_boundary . "\r\n"; $content.= "Content-Disposition: attachment;\r\n"; $content.= "\tfilename=\"" . $anhangarray[$n]['dateiname'] . "\";\r\n"; $content.= "Content-Length: " . $anhangarray[$n]['groesse'] . ";\r\n"; $content.= "Content-Type: application/pdf; name=\"" . $anhangarray[$n]['dateiname'] . "\"\r\n"; $content.= "Content-Transfer-Encoding: base64\r\n\r\n"; $content.= $anhangarray[$n]['data'] . "\r\n"; } } $content .= "--" . $mime_boundary . "--"; if (mail($einzelmail, $betreff, $content, $header)) { $versendet++; } } } // Ggf. Mailanhänge löschen if ($a > 0) { for ( $n = 1; $n <= $a; $n++) { if ($anhangarray[$n]['pfad'] != "") {unlink($anhangarray[$n]['pfad']);} } } // Meldung, die in VBA in der MsgBox als .ResponseText erscheint: echo $versendet . " Mail(s) erfolgreich gesendet.";

Ab Excel 365: Funktion FILTER()

Das Vorgehen ist hier immer etwas von den konkreten Gegebenheiten abhängig, denn die Rauten (####) werden nur angezeigt. Dahinter stecken trotzdem die Ergebnisse, man kann also mit diesen Rauten also sogar weiterrechnen. Zum Testen:

• In A8 14:00 eintragen.
• In B8 13:00 eintragen.
• In C8 die Formel =B8-A8 eintragen. Da die Formel ein negatives Ergebnis ergibt, erscheinen die Rauten.
• In C9 die Formel =C8*-1 eintragen. Es erscheint das korrekte Ergebnis, nur als positive Zahl.

Dieses Prinzip kann also verwendet werden, so dass mit der WENN-Funktion auf ein negatives Ergebnis geprüft wird und eine entsprechende Ausgabe erfolgt.

Alternativ kann die Prüfung bereits bei der Berechnung erfolgen:

=WENN(A8<B8;(A8-B8)*-1;A8-B8)

Nur ist hier der Nachteil, dass immer ein positives Ergebnis angezeigt wird. Ggf. könnte man per bedingter Formatierung darauf aufmerksam machen, aber die positive Zahl bleibt.

Kommt es auf weitere Berechnungen nicht an, sondern nur auf diese Anzeige, kann das Minuszeichen hinzugefügt werden:

=WENN(A8<B8;"-"&TEXT((A8-B8)*-1;"[hh]:mm");A8-B8)

Das negative Ergebnis liegt dann jedoch als Text vor - bei Berechnungen kann es nun Fehlermeldungen geben.

Wie vorgegangen wird, muss also im Einzelfall entschieden werden.

Auf das 1904-Datumsformat wird hier nicht eingegangen, weil das Probleme bereiten kann.

Hinweis:
Dieser Artikel zeigt gleichzeitig Möglichkeiten zur Arbeit mit benutzerdefinierten Funktionen (Datenfeld als Rückgabewert bzw. Ergebnis), mehrdimensionalen Arrays, regulären Ausdrücken (regular Expressions), verschiedenen Schleifen und mehr.

Variante 1

Die erste Variante hält sich genau an die Aufgabenstellung, dass also an einer führenden Ganzzahl genau ein Buchstabe sein darf. Dazwischen darf sich keine Leerstelle befinden.

Es wird eine Schleife über alle Zellen so lange durchlaufen, bis die Daten tatsächlich sortiert sind, bolSortiert also nicht mehr False wird.

In der Schleife werden aus der gerade durchlaufenen Zeile und aus der nächsten Zeile die Zahlen extrahiert, aus 100b also die 100. Diese Zahlen werden den Variablen c und d zugewiesen.

Im nächsten Schritt wird geprüft, ob die folgende Zahl kleiner als die aktuelle ist. Wenn ja, werden die beiden Zellinhalte getauscht, so dass die kleinere Zahl zuerst steht.

Sind die Zahlen jedoch gleich, wie es bei 100a und 100b der Fall ist, wird geprüft, ob die rechte Stelle (Right(b, 1)) der nächsten Zeile kleiner als die der aktuellen Zeile ist. Zum Beispiel ist das a in 100a kleiner als das b in 100b. Wenn ja, werden die Zellen getauscht.

In beiden ja-Fällen wird die Variable bolSortiert auf False gesetzt, so dass die Do-Loop-Schleife wei�, dass sie von vorn beginnen, also die For-Schleife über die Zellen neu starten soll.

Sub SortierenEinfach() Dim lngEZ As Long, lngLZ As Long, intS As Integer, lngI As Long Dim a, b, c, d Dim bolSortiert As Boolean lngEZ = 1 'erste Zeile - anpassen! intS = 1 'Spalte A lngLZ = Cells(Rows.Count, intS).End(xlUp).Row Do bolSortiert = True For lngI = lngEZ To lngLZ - 1 a = Cells(lngI, intS) b = Cells(lngI + 1, intS) If IsNumeric(a) = False Then If a <> "" Then c = Left(a, Len(a) - 1) Else c = 0 Else: c = a End If If IsNumeric(b) = False Then If b <> "" Then d = Left(b, Len(b) - 1) Else d = 0 Else: d = b End If If CInt(d) < CInt(c) Then Cells(lngI, intS) = b Cells(lngI + 1, intS) = a bolSortiert = False ElseIf CInt(c) = CInt(d) Then If Right(b, 1) < Right(a, 1) Then Cells(lngI, intS) = b Cells(lngI + 1, intS) = a bolSortiert = False End If End If Next Loop While bolSortiert = False End Sub

---

Erweiterte Variante mit benutzerdefinierter Funktion (UDF)

Was nun aber, wenn man nicht voraussetzen kann, dass die Syntax dem Schema entspricht? Wenn es zum Beispiel Leerstellen zwischen Zahl und Buchstaben oder mehrere Buchstaben geben kann? Oder vielleicht sogar negative Zahlen?

In dem Fall versagt die erste Variante.

Für diese Eventualitäten müssen wir den String aus Zahl und Text besser aufteilen. Mit Right(String, 1) geht es nicht, da wir damit immer nur den letzten Buchstaben erwischen würden. Split ist auch nicht möglich, da wir kein Trennzeichen haben und der Split auf "" den kompletten String zurückgibt. Also müssen wir das selbst machen.

Da das etwas länger wird und wir den Code zum Extrahieren der Zahl zweimal brauchen, er also zweimal in der Scheife vorkommen würde, schreiben wir dazu eine Funktion, der wir den kompletten String aus Zahl und möglichen Buchstaben übergeben. Als Ergebnis erhalten wir ein Datenfeld aus zwei Elementen. Im ersten steht die extrahierte Zahl oder 0, wenn keine Zahl im String entalten ist. Im zweiten Element steht die Buchstabenfolge vom Schluss des Originalstrings oder "", wenn es keine Buchstaben gibt.

Die beiden Elemente werden vorbelegt, so dass später nur die �nderungen übergeben werden müssen. Zu sehen ist, dass als Zahl erkannt wird, wenn es sich um eine Zahl, ein Komma oder ein Minus handelt. Bei Bedarf kann das natürlich angepasst werden. Wichtig ist, dass die Zahlen-Zeichenfolge nicht mehr erweitert wird, wenn einmal ein anderes Zeichen erkannt wurde. Deshalb (und falls mal keine Ziffer am Anfang steht) wurde bolZahl = True gesetzt. Sobald im String kein Zahlzeichen (Ziffer, Komma, Minus) gefunden wird, ist diese Variable False und es wird alles dem Buchstabenstring zugeordnet - auch, wenn später im String noch eine Ziffer kommen sollte.

Damit der Zahlenstring später als Zahl erkannt wird, wird einfach mit 1 multiplizert, um etwas zu berechnen. Man kann das natürlich auch an eine extra dafür deklarierte Variable übergeben.

Das ist die Funktion:

Function StringSplit(ByVal varWert As Variant) Dim arrErgeb(1 To 2) Dim strZahl As String, strString As String, bolZahl As Boolean Dim intN As Integer arrErgeb(1) = 0 'vorbelegen, später werden nur �nderungen übergeben arrErgeb(2) = "" If IsNumeric(varWert) Then arrErgeb(1) = varWert * 1 Else strZahl = "": strString = "": bolZahl = False For intN = 1 To Len(varWert) If IsNumeric(Mid(varWert, intN, 1)) Or Mid(varWert, intN, 1) = "," Or Mid(varWert, intN, 1) = "-" Then If strString = "" Then strZahl = strZahl & Mid(varWert, intN, 1) bolZahl = True Else If intN = 1 Then bolZahl = True If bolZahl Then strString = strString & Mid(varWert, intN, 1) End If Next arrErgeb(1) = IIf(strZahl = "", 0, strZahl * 1) arrErgeb(2) = Trim(strString) End If StringSplit = arrErgeb End Function

Die eigentliche Routine zum Sortieren ist dann vom Aufbau her wie die vorige, nur dass anstelle der Variablen c und d die Rückgaben aus der Funktion stehen:

Sub SortierenAlphaNum() Dim lngEZ As LongPtr, lngLZ As LongPtr, intS As Integer, lngZ As LongPtr Dim a, b Dim bolSortiert As Boolean Dim arrA(), arrB() lngEZ = 1 'erste Zeile - anpassen! intS = 1 'Spalte A lngLZ = Cells(Rows.Count, intS).End(xlUp).Row Do bolSortiert = True For lngZ = lngEZ To lngLZ - 1 a = Cells(lngZ, intS) b = Cells(lngZ + 1, intS) arrA = StringSplit(Cells(lngZ, intS)) arrB = StringSplit(Cells(lngZ + 1, intS)) 'die nächste Zahl ist kleiner als die aktuelle: If arrB(1) < arrA(1) Then Cells(lngZ, intS) = b Cells(lngZ + 1, intS) = a bolSortiert = False 'nächste Zahl ist wie die aktuelle, mögliche Strings prüfen ElseIf arrA(1) = arrB(1) Then If arrB(2) < arrA(2) Then Cells(lngZ, intS) = b Cells(lngZ + 1, intS) = a bolSortiert = False End If End If 'Falls Datensätze im Spiel sind und die Daten sortiert werden sollen, 'können die folgenden Zeilen die Nummern gesplittet in die Nachbarzellen 'schreiben, um dann danach zu sortieren: Cells(lngZ, intS + 1) = arrA(1) Cells(lngZ, intS + 2) = arrA(2) If lngZ = lngLZ - 1 Then Cells(lngZ + 1, intS + 1) = arrB(1) Cells(lngZ + 1, intS + 2) = arrB(2) End If Next Loop While bolSortiert = False End Sub

---

Variante mit regulären Ausdrücken/Regular Expressions

Das mit der Funktion ist zu lang? Kein Problem, es geht auch kürzer. Wenn im VB-Projekt ein Verweis zu Microsoft VBScript Regular Expressions gesetzt wird, können wir reguläre Ausdrücke verwenden.

Das Suchmuster wäre in diesem Fall:

regex.Pattern = "^([-0-9,]+)([ a-zA-Z0-9]*)$"

Das hei�t, am Anfang des Strings mit Zahl und Buchstaben muss eins der Zeichen von 0 bis 9, ein Minus oder ein Komma wenigstens einmal (deshalb das +) stehen. Dahinter kann (deshalb das *) eine Kombination aus Leerzeichen, Buchstaben und weiteren Ziffern folgen. Diese beiden Teile stehen in runden Klammern und werden dann an die Variablen arrA und arrB übergeben, wenn Matches gefunden wurden. Im jeweils ersten Element (arrA(1) und arrB(1) ) der Variablen stehen wieder die Zahlen, die - damit sie nicht als Text erkannt werden - mit 1 multipliziert werden.

Der Rest ist dann so wie bei den anderen beiden Varianten.

Sub SortierenAlphaNumRegex() Dim regex As New RegExp Dim regMatches As MatchCollection, regMatch As Match Dim lngEZ As LongPtr, lngLZ As LongPtr, intS As Integer, lngZ As LongPtr Dim a, b Dim bolSortiert As Boolean Dim arrA(1 To 2), arrB(1 To 2) lngEZ = 1 'erste Zeile - anpassen! intS = 1 'Spalte A lngLZ = Cells(Rows.Count, intS).End(xlUp).Row regex.Pattern = "^([-0-9,]+)([ a-zA-Z0-9]*)$" Do bolSortiert = True For lngZ = lngEZ To lngLZ - 1 a = Cells(lngZ, intS) arrA(1) = 0: arrA(2) = "" Set regMatches = regex.Execute(Cells(lngZ, intS)) If regMatches.Count > 0 Then arrA(1) = regMatches(0).SubMatches(0) * 1 arrA(2) = regMatches(0).SubMatches(1) End If b = Cells(lngZ + 1, intS) arrB(1) = 0: arrB(2) = "" Set regMatches = regex.Execute(Cells(lngZ + 1, intS)) If regMatches.Count > 0 Then arrB(1) = regMatches(0).SubMatches(0) * 1 arrB(2) = regMatches(0).SubMatches(1) End If 'die nächste Zahl ist kleiner als die aktuelle: If arrB(1) < arrA(1) Then Cells(lngZ, intS) = b Cells(lngZ + 1, intS) = a bolSortiert = False 'nächste Zahl ist wie die aktuelle, mögliche Strings prüfen ElseIf arrA(1) = arrB(1) Then If arrB(2) < arrA(2) Then Cells(lngZ, intS) = b Cells(lngZ + 1, intS) = a bolSortiert = False End If End If 'Falls Datensätze im Spiel sind und die Daten sortiert werden sollen, 'können die folgenden Zeilen die Nummern gesplittet in die Nachbarzellen 'schreiben, um dann danach zu sortieren: Cells(lngZ, intS + 1) = arrA(1) Cells(lngZ, intS + 2) = arrA(2) If lngZ = lngLZ - 1 Then Cells(lngZ + 1, intS + 1) = arrB(1) Cells(lngZ + 1, intS + 2) = arrB(2) End If Next Loop While bolSortiert = False End Sub

---

Beschleunigen: Sortieren per Array

Schnell wird man feststellen, dass die Laufzeit bei solchen Routinen sehr lang werden kann. Die Ursache liegt hier jedoch weniger bei den Schleifen, sondern eher darin, dass immer wieder Lese- und Schreibzugriffe auf die Zellen erfolgen. Das bremst die Schleifen aus.

Nun könnten wir mit Application.ScreenUpdating = False die Bildschirmaktualisierung ausschalten. Das würde tatsächlich ein paar Zehntelsekunden bringen, vielleicht auch Sekunden. Schneller geht es jedoch, wenn wir für den eigentlich Sortiervorgang gar nicht auf die Zellen zugreifen.

Dazu lesen wir alle Zellen zunächst in einen Array ein:

Dim arrSamm(), arrTemp lngEZ = 1 'erste Zeile - anpassen! intS = 1 'Spalte A lngLZ = Cells(Rows.Count, intS).End(xlUp).Row ReDim Preserve arrSamm(1 To 2, lngEZ To lngLZ) For lngZ = lngEZ To lngLZ arrSamm(1, lngZ) = Cells(lngZ, intS) Next

arrSamm() hat hier zwei Spalten (1 To 2), obwohl nur eine reichen würde. Die zweite Spalte wird in diesem Beispiel nur die aufgesplitteten Strings, also die Zahlen und die Buchstaben, zur späteren Ausgabe aufnehmen - diese jeweils als Datenfelder. In der ersten SDpalte von arrSamm() werden also die zu sortierenden Strings stehen, in der zweiten die getrennten Daten.

Sind die Daten im Array, führen wir dort den Sortiervorgang durch. Das Prinzip ist genau das der bisherigen Varianten, nur eben nicht an Zellen.

Erst ganz zum Schluss schreiben wir den - nun sortierten - Array wieder in die Zellen:

For lngZ = lngEZ To lngLZ Cells(lngZ, 1) = arrSamm(1, lngZ) arrTemp = arrSamm(2, lngZ) Cells(lngZ, 2) = arrTemp(1) Cells(lngZ, 3) = arrTemp(2) Next

Die Routine als Ganzes:

Sub SortierenAlphaNumRegexArray() Dim Regex As New RegExp Dim regMatches As MatchCollection, regMatch As Match Dim lngEZ As LongPtr, lngLZ As LongPtr, intS As Integer, lngZ As LongPtr Dim a, b Dim bolSortiert As Boolean Dim arrA(1 To 2), arrB(1 To 2) Dim arrSamm(), arrTemp lngEZ = 1 'erste Zeile - anpassen! intS = 1 'Spalte A lngLZ = Cells(Rows.Count, intS).End(xlUp).Row ReDim Preserve arrSamm(1 To 2, lngEZ To lngLZ) For lngZ = lngEZ To lngLZ arrSamm(1, lngZ) = Cells(lngZ, intS) Next Regex.Pattern = "^([-0-9,]+)([ a-zA-Z0-9]*)$" Do bolSortiert = True For lngZ = lngEZ To lngLZ - 1 a = arrSamm(1, lngZ) arrA(1) = 0: arrA(2) = "" Set regMatches = Regex.Execute(a) If regMatches.Count > 0 Then arrA(1) = regMatches(0).SubMatches(0) * 1 arrA(2) = regMatches(0).SubMatches(1) arrSamm(2, lngZ) = arrA 'für die spätere Ausgabe in den Nachbarzellen End If b = arrSamm(1, lngZ + 1) arrB(1) = 0: arrB(2) = "" Set regMatches = Regex.Execute(b) If regMatches.Count > 0 Then arrB(1) = regMatches(0).SubMatches(0) * 1 arrB(2) = regMatches(0).SubMatches(1) arrSamm(2, lngZ + 1) = arrB 'für die spätere Ausgabe in den Nachbarzellen End If If arrB(1) < arrA(1) Then 'die nächste Zahl ist kleiner als die aktuelle: arrSamm(1, lngZ) = b: arrSamm(2, lngZ) = arrB arrSamm(1, lngZ + 1) = a: arrSamm(2, lngZ + 1) = arrA bolSortiert = False ElseIf arrA(1) = arrB(1) Then 'nächste Zahl ist wie die aktuelle, mögliche Strings prüfen If arrB(2) < arrA(2) Then arrSamm(1, lngZ) = b: arrSamm(2, lngZ) = arrB arrSamm(1, lngZ + 1) = a: arrSamm(2, lngZ + 1) = arrA bolSortiert = False End If End If Next Loop While bolSortiert = False For lngZ = lngEZ To lngLZ 'Ausgabe Cells(lngZ, 1) = arrSamm(1, lngZ) arrTemp = arrSamm(2, lngZ) Cells(lngZ, 2) = arrTemp(1) Cells(lngZ, 3) = arrTemp(2) Next End Sub

Und schon benötigt das Ganze nur noch einen Bruchteil der bisherigen Laufzeit.

---

Beispieldatei

Diese Beispiele sind in der Beispieldatei enthalten: alphanum_sort.xlsm.

Beachten Sie aber, dass die Routine SortierenEinfach() bei den erweiterten Daten eine Fehlermeldung bringt, denn diese Routine funktioniert nur auf der Basis der in der Aufgabenstellung vorgegebenen Syntax der Daten ZahlBuchstabe. In der Fehlermeldung wird auch angezeigt, an welchem String diese Routine scheitert.

Im Beispiel ist das Problem der Vergleich der Zeile 5 (103b) mit der nächsten Zeile (,55aaa). Die Syntax mit vorangestelltem Komma (was in Excel durchaus möglich ist) und mehreren Buchstaben nach der Zahl kann diese einfache Routine nicht. Die anderen kommen damit klar.

Download: alphanum_sort.xlsm

Die folgende Funktion speichert mit Environ() den lokalen OneDrive-Ordner in eine Variable. Anschlie�end ersetzt sie im Pfad der Datei diverse mögliche Zeichenfolgen, die OneDrive selbst vergibt. Mit einem regulären Ausdruck wird dann der OneDrive-Teil im Pfad der Datei durch den lokalen Pfad ersetzt.

Ggf. können noch ein paar Fehlerbehandlungen eingebaut werden.

Function OneDrive2Lokal(ByVal strPfad As String) As String Dim strOnedrivePfad As String, RegEx As Object, regMatches OneDrive2Lokal = "" If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") If Left(strPfad, 6) = "https:" Then strOnedrivePfad = Environ("OneDrive") & "\" ' oder "OneDriveConsumer" strPfad = Replace(strPfad, "^J", ",") strPfad = Replace(strPfad, "^N", "#") strPfad = Replace(strPfad, "^0", "&") RegEx.Pattern = "^(https:/{2}[A-Za-z0-9./]+/)" Set regMatches = RegEx.Execute(strPfad) strPfad = Replace(RegEx.Replace(strPfad, strOnedrivePfad), "/", "\") End If OneDrive2Lokal = strPfad Set RegEx = Nothing End Function

Die Funktion kann beliebig verwendet werden, zum Beispiel:

MsgBox OneDrive2Lokal(ThisWorkbook.FullName)

Worksheet_Change-Ereignis

Die Routine wird im VBA-Editor in das Modul eingetragen, das durch Doppelklick auf die Tabelle, in der der Code wirken soll, geöffnet wird. Es werden hier zwei Varianten aufgezeigt: In Spalte B wird eine Formel eingetragen, die das Ergebnis liefert. Falls ein Ergebnis ohne Formel gewünscht wird, wird dies noch in Spalte C eingetragen.

Die Routine wird nur ausgeführt, wenn die Eingabezelle in Spalte 1 (A) ist. Dann werden zunächst die Zielzellen daneben in B und C geleert.

Da intern mit Punkt statt Komma als Dezimaltrenner gerechnet wird, wird ein eventuell vorhandenes Komma zuerst ersetzt. AnschlieÃ?end wird mit Evaluate versucht, zu berechnen. Wird die Berechnung erkannt, wird ein Ergebnis geliefert, sonst der Fehler #NAME?. Letzteres kommt zum Beispiel vor, wenn ein Text in A eingetragen wurde.

Tritt kein Fehler auf, wird in B die entsprechende Formel eingetragen, in C direkt das Ergebnis.

Private Sub Worksheet_Change(ByVal Target As Range) Dim varTemp, varErg If Target.Column > 1 Then Exit Sub Range("B" & Target.Row & ":C" & Target.Row).ClearContents varTemp = Replace(Target, ",", ".") varErg = Application.Evaluate(varTemp) If Not IsError(varErg) Then Cells(Target.Row, 2).Formula = "" & "=" & varTemp & "" Cells(Target.Row, 3) = varErg End If End Sub

---

UDF - benutzerdefinierte Funktion

Es ist (in diesem Fall ab Excel 365) auch möglich, das Ergebnis der Berechnung ohne Gleichheitszeichen per Formel zu erhalten. Notwendig ist dazu eine solche benutzerdefinierte Funktion in einem Standardmodul:

Function Evaluate_String(ByVal strString As String, Optional intWas As Integer = 0) Dim varTemp, varErg Evaluate_String = "" varTemp = Replace(strString, ",", ".") varErg = Application.Evaluate(varTemp) If Not IsError(varErg) Then Evaluate_String = IIf(intWas <> 0, "=" & varTemp & "", varErg) End Function

In die Zelle, in der das Ergebnis der Formel ohne Gleichheitszeichen erscheinen soll, muss dann nur:

=Evaluate_String(C10)

Wenn die Formel nicht das Ergebnis, sondern die Formel (also mit Gleichheitszeichen) anzeigen soll, kann als zweiter Parameter etwas anderes als 0 verwendet werden, zum Beispiel:

=Evaluate_String(C10;1)

Sie hat dann ein vergleichbares Verhalten wie die integrierte Funktion FORMELTEXT().

Ribbonkalender

Das Add-In stellt im Menüband (Ribbon) einen Kalender zur Verfügung, über den verschiedene Funktionen aufrufbar sind. Gleichzeitig kann eingestellt werden, dass ein kleiner Kalender immer an der aktiven Zelle ist, so dass Datumsangaben einfach in die Zelle geklickt werden können. Für Uhrzeit-Eingaben ist es möglich, ein alternatives Zeichen als den Doppelpunkt zu verwenden, zum Beispiel das Plus auf dem Numblock. Usw. usf. - die Funktionen sind im Video dargestellt:
 

Das Add-In sollte ab Excel 2007 funktionieren. Nach dem Installieren muss Excel neu aufgerufen werden. Es kann frei genutzt, darf aber nicht geändert werden.

Download: ribbonkalender.xlam

Auf fünf Cent:

=VRUNDEN(A1;0,05)

Auf volle Fünfer:

=VRUNDEN(A1;5)

Eine Schleife ist das wiederholte Abarbeiten eines Befehls oder einer Folge von Befehlen, bis eine bestimmte Bedingung erfüllt ist. Wird keine oder eine falsche Bedingung vorgegeben, wird die Schleife nicht abgebrochen. Dann spricht man von einer Endlosschleife. In VBA kann sie dafür sorgen, dass die ausführende Anwendung (hier also z. B. Excel) einfriert, also nicht mehr reagiert.

1. For-Schleife

In dieser Schleife verändert die Variable i ihren Wert von 1 bis 5 in Einerschritten, der letzte Wert ist also vorgegeben (Abbruchbedingung). Für jeden Wert wird eine Meldung ausgegeben.

Sub Schleife() For i = 1 To 5 MsgBox i Next i End Sub

2. While-Schleife:

Auch in dieser Schleife verändert die Variable i ihren Wert, der zuerst mit 1 festgelegt ist. Aber mit Do While i <= 5 wird festgelegt, da� die Schleife so lange zu durchlaufen ist, wie der Wert von i kleiner oder gleich 5 ist. Bei jedem Durchlauf soll die Meldung i ausgegeben und i um den Wert 1 erhöht werden.

Sub Schleife2() i = 1 Do While i <= 5 MsgBox i i = i + 1 Loop End Sub

In VBA gibt es bei While noch einige andere Varianten. So kann die Ausführungsdauer am Ende definiert werden (Loop While �) oder es kann auch eine Bis-Bedingung festgelegt werden (Do Until � oder Loop Until).

3. Sprungmarke:

Hier hat die Variable i auch den Startwert 1. Aber im Unterschied zu den anderen Beispielen wird hier mit einer If-Then-Else-Abfrage gearbeitet. Wenn i kleiner oder gleich 5 ist, soll die Meldung i erscheinen, anschlie�end zu i der Wert 1 addiert und bei der Sprungmarke nochmal: fortgesetzt werden. Wenn i im Beispiel den Wert 6 hat, ist die Bedingung i <= 5 nicht erfüllt, die Abfragebedingung ist nicht mehr erfüllt; somit werden die Schritte zwischen If und End If nicht mehr durchgeführt.

Sub Schleife3() i = 1 nochmal: If i <= 5 Then MsgBox i i = i + 1 GoTo nochmal End If End Sub

Hinweis: Die Arbeit mit Sprungmarken ist veraltet und kein guter Stil. AuÃ?erdem handelt es sich dabei eigentlich nicht um eine wirkliche Schleife.

4. Endlosschleife:

Bei dieser Schleife handelt es sich um eine Endlosschleife. Es wurde eine falsche Abbruchbedingung festgelegt (i >= 1); i wird in diesem Beispiel immer grö�er oder gleich 1 sein. Deshalb wird die Schleife ohne Ende weitergeführt. Hier kann die Schleife nur mit Esc abgebrochen werden (wenn kein Dialogfeld aktiv ist) bzw. mit Strg + Pause. Oder im Ernstfall mit Strg + Alt + Entf.

Sub Schleife4() i = 1 Do While i >= 1 i = i + 1 Loop End Sub

Dazu wird der X-Button (also Schlie�en-Button) zwar nicht ausgeblendet, aber das Dialogfeld lä�t sich darüber nicht schlie�en. Damit ist auch Alt + F4 entschärft und die Userform lässt sich nur mit einer eigenen Schaltfläche schlie�en, die zweckmä�igerweise erst eingebaut werden sollte. Das funktioniert auch, wenn beim eigenen Button Cancel und/oder Default auf True gesetzt sind.

Das Makro bei den Userform-Ereignissen einfügen (Doppelklick auf Userform im Editor):

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = 1 MsgBox "Bitte verlassen Sie das Dialogfeld mit den Schaltflächen.", vbOKOnly + vbInformation, "Bitte Schaltfläche betätigen." End If End Sub

Split()

Die folgende Funktion splittet den String am Trenner und gibt - wenn vorhanden - das Element intWelcher zurück:

Function SplitString(strString, intWelcher, strTrenner) Dim arrTemp SplitString = "" arrTemp = Split(strString, strTrenner) If UBound(arrTemp) >= intWelcher - 1 Then SplitString = arrTemp(intWelcher - 1) End Function

Eingesetzt wird sie so: MsgBox SplitString("abc;cde;890;321", 3, ";"). Oder als Formel in eine Zelle.

---

Array, implizite Schnittmenge, impliziter Schnittpunktoperator @

Ab Excel 365 ist es auch möglich, die aufgeteilte Zeichenfolge insgesamt ausgeben zu lassen. Für das Beispiel die folgende Funktion:

Function Stringteile(strString, strTrenner) Dim arrTemp arrTemp = Split(strString, strTrenner) Stringteile = IIf(UBound(arrTemp) > 0, arrTemp, "") End Function

---

Für sehr alte Excelversionen

Die hier dargestellte Funktion stellt eine Alternative zur Funktion Split() dar, die es in niedrigeren Excelversionen noch nicht gab. Alternativ kann die Funktion auch als Tabellenblattfunktion verwendet werden, wenn man Daten - Text in Spalten nicht verwenden kann.

An die Funktion wird übergeben, welcher String aufgeteilt werden soll (strString), der wievielte Eintrag zurückgegeben werden soll (intWelcher) und um welches Trennzeichen es sich handelt (strTrenner).

Function SemiTrenner(strString, intWelcher, strTrenner) Dim intI As Integer Dim intZaehler As Integer Dim intBeginn As Integer, intEnde As Integer intBeginn = 0 intEnde = 0 intZaehler = 1 If Right(strString, 1) <> strTrenner Then strString = strString & strTrenner For intI = 1 To Len(strString) + 2 If Mid(strString, intI, 1) = strTrenner Then If intZaehler = 1 And intWelcher = 1 Then intBeginn = 1 intEnde = intI Exit For ElseIf intZaehler = intWelcher Then intBeginn = intEnde + 1 intEnde = intI Exit For End If intZaehler = intZaehler + 1 intEnde = intI End If Next If intBeginn > 0 And intEnde > 0 Then SemiTrenner = Mid(strString, intBeginn, intEnde - intBeginn) Else SemiTrenner = "" End Function

So könnte die Funktion wie folgt eingesetzt werden:

strString = "1;456;78,9bb;543;" MsgBox SemiTrenner(strString, 3, ";")

Das Ergebnis wäre in diesem Fall 78,9bb.

Dazu bietet sich eine Array-Funktion an. Die erreicht man, indem man erst die normale Formel eingibt und die Eingabe mit Strg + Umschalttaste + Enter beendet. Dann werden automatisch um die Formel geschweifte Klammern ({}) gesetzt, woran man die Array-Funktion erkennt.

Beispiel: Folgende Formel summiert, wenn in Spalte A ein a und in derselben Zeile in Spalte B ein h ist, die entsprechenden Werte der Spalte C. Die geschweiften Klammern signalisieren, dass es ein Array ist - diese nicht mit kopieren/eingeben, sondern im Bearbeitungsmodus mit Strg + Umschalttaste + Enter erzeugen.

{=SUMME(WENN(A1:A11="a";WENN(B1:B11="h";C1:C11;"")))}

Ab Excel 365

Ab Excel 365 sind die geschweiften Klammern nicht mehr notwendig, die Formel kann ganz normal eingetragen und die Eingabe einfach mit Enter abgeschlossen werden:

=SUMME(WENN(A1:A11="a";WENN(B1:B11="h";C1:C11;"")))

Hier geht allerdings auch die Funktion SUMMEWENNS(), in die mehrere Kriterien als Parameter eingetragen werden können. Im Beispiel wäre das:

=SUMMEWENNS(C1:C11;A1:A11;"a";B1:B11;"h")

UDF - benutzerdefinierte Funktion

Die Syntax ist die gleiche wie bei der integrierten Funktion SVERWEIS:

=TeilSverweis(Suchkriterium;Matrix;Spaltenindex)

Function TeilSverweis(Suchkriterium As Variant, Bereich As Range, Spaltenindex As Integer) As Variant Dim rngZelle As Range Application.Volatile TeilSverweis = "" If Suchkriterium <> "" Then For Each rngZelle In Bereich If rngZelle.Column = Bereich.Column Then If CStr(Left(rngZelle.Value, Len(Suchkriterium))) = CStr(Suchkriterium) Then TeilSverweis = Cells(rngZelle.Row, rngZelle.Column + Spaltenindex - 1) Exit Function End If End If Next TeilSverweis = "Nicht gefunden" End If End Function

---

Dynamische Arrayfunktion FILTER() (ab Excel 365)

In E1 befindet sich der Suchbegriff.

=SUMME(INDIREKT("B"&VERGLEICH(E1;A1:A15;0)):INDIREKT("D"&VERGLEICH(E1;A1:A15;0)))

---

Dynamische Arrayfunktion (ab Excel 365)

Einsatz dynamischer Arrayfunktionen

Sub Aufteilen_Filter() Dim lngZ As LongPtr, lngLZ As LongPtr, intZ As Integer Dim strAktBlatt As String, strFormel As String Dim wksNeu As Worksheet Dim varFilt, varNamen, varName strAktBlatt = "Mitarbeiter" lngLZ = Cells(Rows.Count, 3).End(xlUp).Row varNamen = Application.WorksheetFunction.Unique(Range("C2:C" & lngLZ)) If IsArray(varNamen) Then For Each varName In varNamen strFormel = "=FILTER(" & strAktBlatt & "!C2:G" & lngLZ & "," & strAktBlatt & "!C2:C" & lngLZ & "=""" & varName & """)" varFilt = Application.Evaluate(strFormel) If IsArray(varFilt) Then Set wksNeu = Worksheets.Add(after:=Sheets(Sheets.Count)) wksNeu.Name = varName Sheets(strAktBlatt).Range("C1:G1").Copy wksNeu.Range("C1") lngZ = 1 If UBound(varFilt) = Application.WorksheetFunction.CountA(varFilt) Then lngZ = lngZ + 1 For intS = 1 To UBound(varFilt) wksNeu.Cells(lngZ, intS + 2) = varFilt(intS) '+2 weil Spalte C Next Else For intZ = 1 To UBound(varFilt) lngZ = lngZ + 1 For intS = 1 To 5 wksNeu.Cells(lngZ, intS + 2) = varFilt(intZ, intS) Next Next End If End If Next End If End Sub

---

Schleife

Vor Excel 365 funktioniert die Variante mit den dynamischen Arrayfunktionen noch nicht. Deshalb hier noch eine ältere Möglichkeit:

Die Routine duchläuft die Spalte der Mitarbeiternamen von oben nach unten. Mit Hilfe der Z�HLENWENN-Funktion wird geprüft, ob sich unterhalb der gerade durchlaufenen Zelle der Name des Mitarbeiters nochmals befindet. Wenn nicht, wird ein neues Blatt mit dem Namen des Mitarbeiters angelegt und es werden die Spaltenüberschriften eingefügt.

Zum Schluss werden die Daten zu den Mitarbeitern auf deren Blättern eingetragen.

Sub Aufteilen_Schleife() Dim lngZ As Long, lngLZ As Long, intAnzahl As Integer Dim lngAktZeile As Long Dim strAktBlatt As String, strName As String Dim ints, intAnzahlTB, intAnzahlSpalten As Integer Dim objNeuBlatt As Worksheet Dim lngErsteZeile As Long Dim strSpalte As String 'Hier anpassen: lngErsteZeile = 2 strSpalte = "C" strAktBlatt = ActiveSheet.Name lngLZ = Range(strSpalte & 65536).End(xlUp).Row 'Blätter mit den Spaltenüberschriften erstellen: For lngZ = lngErsteZeile To lngLZ If Sheets(strAktBlatt).Range(strSpalte & lngZ) <> "" Then intAnzahl = Application.WorksheetFunction.CountIf(Sheets(strAktBlatt).Range(strSpalte & lngZ + 1 & ":" & strSpalte & "65536"), Sheets(strAktBlatt).Range(strSpalte & lngZ)) If intAnzahl = 0 Then Set objNeuBlatt = Worksheets.Add(after:=Sheets(Sheets.Count)) objNeuBlatt.Name = Sheets(strAktBlatt).Range(strSpalte & lngZ) For ints = 1 To Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column objNeuBlatt.Cells(1, ints) = Sheets(strAktBlatt).Cells(1, ints) Next ints End If End If Next lngZ '�bernahme der Daten auf die einzelnen Blätter: intAnzahlSpalten = Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column For lngZ = lngErsteZeile To lngLZ strName = Sheets(strAktBlatt).Range(strSpalte & lngZ) If strName <> "" Then lngAktZeile = Sheets(strName).Range(strSpalte & 65536).End(xlUp).Row + 1 Sheets(strName).Range(Sheets(strName).Cells(lngAktZeile, 1), Sheets(strName).Cells(lngAktZeile, intAnzahlSpalten)).Value = _ Sheets(strAktBlatt).Range(Sheets(strAktBlatt).Cells(lngZ, 1), Sheets(strAktBlatt).Cells(lngZ, intAnzahlSpalten)).Value End If Next lngZ End Sub

VBA

Sub TabellenblattName() MsgBox ActiveSheet.Name End Sub

---

Formel

Die Funktion =ZELLE("Dateiname";A1) gibt den Pfad der Mappe bis zur Tabelle zurück. Der Dateiname steht dabei in eckigen Klammern, danach kommt der Tabellenname. Also kann der Teil von der letzten eckigen Klammer bis zum Schluss extrahiert werden:

=RECHTS(ZELLE("Dateiname");LÃ?NGE(ZELLE("Dateiname"))-FINDEN("]";ZELLE("Dateiname")))

Um den (zweistelligen) Tag mit dem Punkt aus dem Datum zu extrahieren gibt es verschiedene Möglichkeiten. Beispiele:

---

Formel

=TEXT(TAG(A1);"TT")&"."

=LINKS(TEXT(A1;"TT.MM.JJ");3)

---

Format

Einfach die Formel =A1 eintragen und die Zelle benutzerdefiniert mit TT. formatieren.

---

UDF - benutzerdefinierte Funktion

Natürlich geht es auch mit einer UDF, zum Beispiel indem gesplittet wird. Oder mit dieser Regex:

Function Tagausdatum(ByVal strDatum) Dim Regex As Object, regMatches If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = "([0-9]{1,2})\..*" Set regMatches = Regex.Execute(strDatum) Tagausdatum = regMatches(0).SubMatches(0) & "." Set Regex = Nothing End Function

In die Zelle müsste dann:

=Tagausdatum(C1)

In Spalte A wird solange gesucht, bis eine leere Zelle gefunden wird. Natürlich wäre auch eine For-Schleife mit Application.Cells(Rows.Count, 1).End(xlUp).Row möglich.

Die Daten aus A, B und C werden mit einem Semikolon als Trennzeichen in eine Textdatei eingelesen.

Einlesen in eine Textdatei mit immer gleichem Pfad:

Sub AlsTextSpeichern() Dim intI As Integer, lngDNr As LongPtr lngDNr = FreeFile 'Pfad anpassen Open "C:\Eigene Dateien\aus Tabelle.txt" For Output As #lngDNr intI = 2 'erste Zeile mit Angaben Do While Cells(intI, 1).Value <> "" 'Schleife, solange die Zelle nicht leer ist 'Ã?bernehmen der Daten in die Textdatei Print #lngDNr, Cells(intI, 1) & ";" & Cells(intI, 2) & ";" & Cells(intI, 3) intI = intI + 1 Loop Close #lngDNr End Sub

Einlesen in eine Textdatei mit wählbarem Pfad:

Sub AlsTextSpeichern1() Dim intI As Integer, lngDNr As LongPtr Dim varPfad varPfad = Application.GetSaveAsFilename(InitialFileName:="Test", fileFilter:="Textdateien (*.txt), *.txt") If varPfad = False Then Exit Sub lngDNr = FreeFile Open varPfad For Output As #lngDNr intI = 2 Do While Cells(intI, 1).Value <> "" Print #lngDNr, Cells(intI, 1) & ";" & Cells(intI, 2) & ";" & Cells(intI, 3) intI = intI + 1 Loop Close #lngDNr End Sub

Textdatei in Exceldatei einlesen, immer gleicher Pfad:

Da das Semikolon als Trennzeichen verwendet wurde, brauchen wir die Textdatei als solche nicht aus- und in Excel einzulesen, sondern wir können die Datei direkt öffnen:

Sub AusTextAufrufen() On Error Resume Next 'falls Datei nicht existiert 'hier nur den Pfad ändern Workbooks.OpenText Filename:="C:\Eigene Dateien\aus Tabelle.txt", DataType:=xlDelimited, semicolon:=True End Sub

Textdatei in Exceldatei einlesen, wählbarer Pfad:

Sub AusTextAufrufen1() Dim varPfad varPfad = Application.GetOpenFilename(fileFilter:="Textdateien (*.txt), *.txt") If varPfad = False Then Exit Sub Workbooks.OpenText Filename:=varPfad, DataType:=xlDelimited, semicolon:=True End Sub

Gibt es andere Trennzeichen, erfolgt das Aufteilen auf die Zellen natürlich nicht unbedingt. Dann kann entweder mit Split() gearbeitet werden oder es kann mit der integrierten Methode Text in Spalten aufgeteilt werden.

---

Dynamische Arrayformel mit Matrixfunktion

Möglich ist natürlich auch ab Excel 365, die Textdatei mittels benutzerdefinierter Matrixfunktion auszulesen und die Ergebnisse als Array zu übergeben:

Function DateiEinlesen(strDatei, strTrenner, intSpalten) Dim intS As Integer, lngZ As LongPtr Dim lngDNr As Long, strZeile As String, arrTemp Dim arrS() lngDNr = FreeFile lngZ = 0 Open strDatei For Input As #lngDNr Do While Not EOF(lngDNr) Line Input #lngDNr, strZeile If strZeile <> "" Then arrTemp = Split(strZeile, strTrenner) lngZ = lngZ + 1 ReDim Preserve arrS(1 To intSpalten, 1 To lngZ) For intS = 1 To intSpalten If UBound(arrTemp) >= intS Then arrS(intS, lngZ) = arrTemp(intS) Else arrS(intS, lngZ) = "" End If Next End If Loop Close #lngDNr DateiEinlesen = Application.WorksheetFunction.Transpose(arrS) End Function

In die Zelle kommt dann nur noch die Formel:

=DateiEinlesen(Pfad zur Datei;Trennzeichen;Anzahl der Spalten)

=DateiEinlesen(A1;";";4)

Allerdings sollten die Dateien natürlich nicht zu gro� sein, weil die Berechnung dieser Formel sonst alles verzögern würde.

Grundsätzliches

Benutzerdefinierte Funktionen, also UDF, sind Funktionen, die man sich selbst im VBA-Editor erstellt. Dazu benennt man sie nicht mit Sub, sondern mit Function. Der Name der Funktion liefert dabei den Rückgabewert. Hei�t also eine Funktion "MeineFunktion(...)", schreibt man in die Zelle "=MeineFunktion(...)". Ebenfalls kann man Funktionen einsetzen, um durch Subs bestimmte Berechnungen durchführen zu lassen.

Beispiel: Eine Funktion, die immer das Datum zurückgibt, das in 14 Tagen liegt, Die Funktion braucht keine Parameter, sie wäre schlicht und einfach:

Function Datum_14Tage() Datum_14Tage = Date + 14 End Function

Darauf können wir einfach per Sub zugreifen:

Sub Datumstest() MsgBox Datum_14Tage End Sub

Oder in die Zelle eingetragen:

=Datum_14Tage()

---

Ergebnisse/Rückgaben

Prinzipiell können benutzerdefinierte Funktionen alle möglichen Datentypen als Rückgabewerte haben: Strings, Zahlen, Datumsangaben usw. Selbst Arrays können Ergebnisse sein, die dann von anderen Subs verarbeitet werden.

---

Dynamische Arrayformeln/Matrixfunktionen

---

Formel übergelaufen

---

Um zu gewährleisten, dass eine in einem Tabellenblatt eingesetzte UDF immer rechnet, sollte man an den Anfang der Funktion schreiben:

Application.Volatile

An der Stelle des Sternchens in Dir(strOrdner & "*.*") können auch bestimmte Dateiendungen eingetragen wreden, so dass nur nach Dateien eines Typs gesucht wird.

Subs

Sollen Dateien nur direkt im Ordner, nicht aber in Unterordnern, gesucht werden, reicht dieser Code:

Sub Suchen_nur_Dateien() Dim strOrdner As String, strDatei As String Dim lngZ As LongPtr strOrdner = "C:\Eigene Dateien\" lngZ = 2 Range("a1:e50000").ClearContents strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngZ = lngZ + 1 Cells(lngZ, 1) = strOrdner & strDatei 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strDatei) 'Grö�e Cells(lngZ, 3) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit Cells(lngZ, 4) = strDatei 'nur Dateiname End If strDatei = Dir Loop End Sub

Soll auch in Unterordnern gesucht werden, ist dies eine Möglichkeit:

Private lngZ As LongPtr Sub Suchen_mit_Unterordnern() 'Aufruf lngZ = 2 Range("a1:e50000").ClearContents Dateisuche "C:\Eigene Dateien", "*.*" End Sub Sub Dateisuche(strOrdner As String, strDateien As String) Dim strTemp As String, strWdhlg As String strOrdner = strOrdner & IIf(Right(strOrdner, 1) <> "\", "\", "") strTemp = Dir(strOrdner & strDateien) Do While Len(strTemp) Cells(lngZ, 1) = strOrdner & strTemp 'Pfad Cells(lngZ, 2) = FileLen(strOrdner & strTemp) 'Grö�e Cells(lngZ, 3) = FileDateTime(strOrdner & strTemp) 'Datum/Zeit Cells(lngZ, 4) = strTemp 'nur Dateiname lngZ = lngZ + 1 strTemp = Dir() Loop strTemp = Dir(strOrdner, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strOrdner & strTemp) And vbDirectory) = vbDirectory Then Dateisuche strOrdner & strTemp, strDateien lngZ = lngZ - 1 strWdhlg = Dir(strOrdner, vbDirectory) lngZ = lngZ + 1 Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop On Error GoTo 0 End Sub

---

Matrixfunktion für dynamische Arrayformel

Wenn es nicht zu viele Dateien sind, können die auch mit einer Formel, die in einer Zelle steht, ausgegeben werden (ab Excel 365). Dazu dient folgende benutzerdefinierte Funktion (UDF):

Function Suchen_nur_Dateien(strOrdner) Dim strDatei As String, arrTemp() Dim lngArr As LongPtr lngArr = 0 strDatei = Dir(strOrdner & "*.*") Do While strDatei <> "" If strDatei <> "" Then lngArr = lngArr + 1 ReDim Preserve arrTemp(1 To 4, 1 To lngArr) arrTemp(1, lngArr) = strOrdner & strDatei 'Pfad arrTemp(2, lngArr) = FileLen(strOrdner & strDatei) 'Grö�e arrTemp(3, lngArr) = FileDateTime(strOrdner & strDatei) 'Datum/Zeit arrTemp(4, lngArr) = strDatei 'nur Dateiname End If strDatei = Dir Loop Suchen_nur_Dateien = arrTemp End Function

Wenn in A1 der Ordner (z. B. C:\Eigene Dateien\) steht, kann in eine andere Zelle folgende Formel eingetragen werden:

=MTRANS(Suchen_nur_Dateien(A1))

Damit werden die gefundenen Dateien ab der Zelle mit der Formel gefloatet eingetragen (verschüttet). Auch die Suche mit den Unterordnern lässt sich in dieser Form gestalten - aber Vorsicht, damit die Formel nicht ewig zum Berechnen braucht.

1. Die ganze Tabelle markieren,
2. Kopieren,
3. neue Tabelle aktivieren,
4. A1 aktivieren,
5. Inhalte einfügen,
6. Transponieren ankreuzen.

Dynamische Arrayformel

Ab Excel 365 kann die Tabelle auch einfach per Formel gedreht werden. Dazu die Funktion MTRANS() verwenden und den Bereich der Tabelle angeben:

=MTRANS(E1:I3)

Hier wird an den Leerzeichen getrennt, ggf. müssen noch weitere Schreibweisen beachtet werden.

Schleife über die Zellen

Variante 1:

Sub Namen_trennen() Dim rngZelle As Range Dim intS As Integer Dim strV As String Dim arrTemp 'Bereich mu� markiert sein, für jede Zelle in der Markierung: For Each Zelle In Selection With Zelle If .Value <> "" Then arrTemp = Split(.Value, " ") Select Case UBound(arrTemp) Case 0: Cells(.Row, .Column + 1) = .Value Case Else strV = "" For intS = 0 To UBound(arrTemp) - 1 strV = strV & IIf(strV <> "", " ", "") & arrTemp(intS) Next Cells(.Row, .Column + 1) = strV Cells(.Row, .Column + 2) = arrTemp(UBound(arrTemp)) End Select End If End With Next End Sub

Variante 2:

Sub Namen_trennen1() Dim intA As Integer, intB As Integer, intI As Integer Dim Zelle As Object 'Bereich mu� markiert sein, 'für jede Zelle in der Markierung: For Each Zelle In Selection With Zelle If .Value <> "" Then 'Suche nach der ersten Leerstelle intA = InStr(.Value, " ") 'Schleife, falls mehrere durch leer getrennte Vornamen 'vorhanden sind, z. B. Ute Elke Meier For intI = 0 To Len(.Value) intB = InStr(Right(.Value, Len(.Value) - intA), " ") intA = InStr(Right(.Value, Len(.Value) - intA), " ") + intA Next 'Aufteilen auf die 1. Zelle rechts und die 2. Zelle rechts 'Vorname Cells(.Row, .Column + 1).Value = Left(.Value, intA - 1) 'Name Cells(.Row, .Column + 2).Value = Right(.Value, Len(.Value) - intA) End If End With Next End Sub

Text in Spalten

Variante 3:

Sub Namen_trennen2() Dim lngZeile As Long, lngSpalte As Long, strZiel As String lngZeile = ActiveCell.Row: lngSpalte = ActiveCell.Column strZiel = Cells(lngZeile, lngSpalte + 2).Address Selection.TextToColumns Destination:=Range(strZiel), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1)) End Sub

Es ist mit dieser Methode auch möglich, mehr als 2 Wörter, die mit Leerzeichen getrennt sind, in die Nachbarzellen zu übertragen. Sollten in nebenstehenden Zellen Daten stehen, muss man vor der Ausführung des Befehls darauf achten, entsprechend viele Spalten einzufügen.

---

Dynamische Arrayformel mit Matrixfunktion

Je nach Situation kann auch eine Arrayformel in Betracht gezogen werden:

Function NamenTrennen(ByVal strName As String, Optional intAnzahl As Integer = 5) Dim arrTemp, intS As Integer ReDim arrNamen(1 To intAnzahl) NamenTrennen = "" For intS = 1 To intAnzahl arrNamen(intS) = "" Next If strName <> "" Then arrTemp = Split(strName, " ") For intS = 0 To UBound(arrTemp) If intS < intAnzahl Then arrNamen(intS + 1) = arrTemp(intS) Next End If NamenTrennen = arrNamen End Function

In die Zelle kommt dazu diese überlaufende Formel:

=NamenTrennen(A1)

Da die Anzahl der Namensteile variieren kann, ein Array aber (in diesem Fall) immer gleich breit ist, ist eine Breite von fünf Zellen voreingetragen. Der Array wird dabei von links gefüllt, so dass die einzelnen Teile in der linken Zelle beginnen. Mit einem zweiten Parameter in der Funktion kann diese Breite geändert werden, zum Beispiel auf vier Zellen Breite:

=NamenTrennen(A1;4)

Besteht der Name dann aus mehr Teilen, werden die restlichen rechten Teile nicht angezeigt.

SVERWEIS()

=SVERWEIS(MAX(A:A);A:B;2;0)

---

Ab Excel 365: FILTER()

UDF - benutzerdefinierte Funktion

Wenn der Bereich nicht zu groÃ? ist, kann folgende benutzerdefinierte Funktion verwendet werden:

Function Zaehlen(Bereich As Range, Minimum, Maximum) Dim objZelle As Object, intI As Integer intI = 0 For Each objZelle In Bereich If objZelle.Value >= Minimum And objZelle.Value <= Maximum Then intI = intI + 1 End If Next Zaehlen = intI End Function

In die Zelle muÃ? dann eingegeben werden:

=Zählen(Bereich;kleinste Zahl;grö�te Zahl)

=Zählen(A1:A100;10;20)

---

Formel

Am einfachsten ist jedoch, wenn die integrierte Funktion ZÃ?HLENWENNS() verwendet wird:

=ZÃ?HLENWENNS(A1:A10;">2";A1:A10;"<7")

---

Dynamische Arrayfunktion (ab Excel 365)

Sollen die Zahlen, die zu den Kriterien passen, auch gleich ausgegeben werden, kann das mit der Funktion FILTER() erfolgen:

=FILTER(A1:A10;(A1:A10>2)*(A1:A10<7);"")

Die Zahlen stehen dann untereinander an der Zelle mit der Formel und können auch mit ANZAHL() gezählt werden. Dabei gibt es jedoch eine Besonderheit.

Gibt man =ANZAHL( ein und zieht dann über den Bereich mit den gefundenen Zahlen, wird in die Funktion nicht der Bereich eingetragen, sondern eine ID wie zum Beispiel C3#:

=ANZAHL(C3#)

Die vergibt Excel selbst. Dabei handelt es sich um eine Referenz auf das Ergebnis der Funktion FILTER(), denn die Grö�e der Ergebnismenge dieser Funktion kann sich ja ändern. Durch diese Referenz wird immer richtig gezählt - egal, ob FILTER() 0, 5 oder sonst wie viele Ergebnisse liefert.

Natürlich ist auch sowas möglich:

=ANZAHL(FILTER(A1:A10;(A1:A10>2)*(A1:A10<7);""))

Hier werden zwei Varianten vorgestellt, bei denen Werte in mehrere Zellen in einer Zeile eingegeben werden können und diese als Filterkriterium dienen. Die Zellen, in die die Filterkriterien eingegeben werden können, sind hier A2:G2, also die ersten sieben Zellen in Zeile 2. Die Tabelle mit den zu filternden Werten ist darunter von A5:Gx.

In beiden Fällen im VBA-Editor auf die entsprechende Tabelle doppelklicken und den Code dort einfügen.

Ein Kriterium

Im ersten Beispiel richtet sich der Filter nach nur einem Kriterium, also einer Zelle in A2:G2. Wenn also z. B. in B2 etwas eingegeben wird, soll die Tabelle nach dem Eintrag in B2 gefiltert werden - etwaige Eintragungen in anderen Zellen in Zeile 2 werden ignoriert bzw. gelöscht:

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngLZ As LongPtr, intS As Integer, intSAkt As Integer, bolEvent As Boolean If Target.Row <> 2 Or Target.Column > 7 Then Exit Sub lngLZ = Cells(Rows.Count, 1).End(xlUp).Row If ActiveSheet.AutoFilterMode = True Then If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData ActiveSheet.Range("A4:G" & lngLZ).AutoFilter End If bolEvent = Application.EnableEvents Application.EnableEvents = False For intS = 1 To 7 If intS <> Target.Column Then Cells(2, intS).ClearContents Next Application.EnableEvents = bolEvent If Target <> "" Then ActiveSheet.Range("A4:G" & lngLZ).AutoFilter Field:=Target.Column, Criteria1:=Range(Target.Address) End Sub

Nach der Eingabe werden zunächst alle Zeilen eingeblendet und der Autofilter ausgeschaltet, falls er gesetzt ist. Anschlie�end wird ausgeschaltet, dass die Tabelle auf Ereignisse reagiert (da es sonst zu Endlosschleifen kommen könnte) und die Inhalte der anderen Zellen in Zeile 2 werden gelöscht. Danach wird der Autofilter auf der Basis der aktuellen Eingabe gesetzt.

---

Mehrere Kriterien

In der zweiten Variante sind in Zeile 2 mehrere Einträge möglich und der Autofilter wird auf der Basis dieser Einträge gesetzt. Das Vorgehen entspricht ansonsten der ersten Variante.

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngLZ As LongPtr, intS As Integer If Target.Row <> 2 Or Target.Column > 7 Then Exit Sub lngLZ = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet If .AutoFilterMode = True Then If .FilterMode = True Then .ShowAllData .Range("A4:G" & lngLZ).AutoFilter End If For intS = 1 To 7 If .Cells(2, intS) <> "" Then .Range("A4:G" & lngLZ).AutoFilter Field:=intS, Criteria1:=.Cells(2, intS).Value End If Next End With End Sub

---

Eingabe nur in A2 - ältere Variante mit weniger Funktionalität

Im VBA-Editor auf die Tabelle doppelt klicken, in der es funktionieren soll. Anschlie�end in das Modul einfügen:

Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address <> "$A$2" Then Exit Sub ActiveSheet.Range("A4:B" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter If Range("A2") <> "" Then ActiveSheet.Range("A4:B" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Range("a2") End If End Sub

Die Funktion INFO() ist nützlich für diverse Informationen zur Umgebung: support.microsoft.com. Beispiele (F9 drücken zum Aktualisieren):

=INFO("Sysversion")

gibt die Windowsversion zurück

=INFO("version")

gibt die Excel-Version zurück

Die folgende Funktion stellt ersten und letzten Tag der Kalenderwoche fest und gibt auf dieser Basis den Zeitraum aus:

Function Zeitraum(ByVal Jahr As Integer, ByVal KW As Variant) As String Dim datBeg As Date, lngT As LongPtr Application.Volatile Zeitraum = "" If IsNumeric(Jahr) And IsNumeric(KW) Then lngT = DateSerial(Jahr, 1, 4) lngT = lngT - Weekday(lngT, 2) + 7 * KW - 7 If (Year(lngT + 4) = Jahr) Then datBeg = lngT + 1 Zeitraum = Format(datBeg, "DD.MM.YYYY") & " - " & Format(datBeg + 6, "DD.MM.YYYY") End If End Function

In die Zelle muss dann nur noch:

=Zeitraum(Jahr;KW)

Soll es ohne Funktion in der Zelle funktionieren und der Zeitraum sofort eingetragen werden, kann folgender Code in das Klassenmodul der jeweiligen Tabelle (Doppelklick auf Tabelle im VBA-Editor):

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row >= 4 And Target.Column = 1 Then Application.EnableEvents = False Target = Zeitraum(Range("B1"), Target) Application.EnableEvents = True End If End Sub

Der Code wird ausgeführt, wenn die Eingabezelle in Spalte 1 und Zeile >= 4 liegt; verwendet wird das Jahr aus Zelle B1. Application.EnableEvents = False ist hier wichtig, weil die eingegebene KW durch den Zeitraum überschrieben wird und das Change-Ereignis sonst immer wieder aufgerufen würde.

Hier ist eine benutzerdefinierte Funktion:

Function zahl_aufteilen(Zahl, Ziffer, Trenner) Application.Volatile Dim intI As Integer Dim strTemp As String, strTrenner As String strTrenner = Ziffer & Trenner strTemp = Replace(Zahl, Ziffer, strTrenner) If Right(strTemp, 1) = Trenner Then strTemp = Left(strTemp, Len(strTemp) - 1) zahl_aufteilen = strTemp End Function

Dazu mit Alt und F11 den Editor aufrufen, ein Modul einfügen und die Function eingeben. In die Zelle kommt dann z. B. die folgende Formel:

=zahl_aufteilen(B6;0;"-")

---

Regulärer Ausdruck

Eine weitere Variante ist diese Funktion:

Function Zahl_Aufteilen_Regex(ByVal varZahl, ByVal strTrenner As String, intZiffer As Integer) Dim Regex As Object, regMatches Set Regex = CreateObject("VBScript.RegExp") Regex.Global = True Regex.Pattern = intZiffer & "\B" Set regMatches = Regex.Execute(varZahl) Zahl_Aufteilen_Regex = Regex.Replace(varZahl, intZiffer & strTrenner) Set Regex = Nothing End Function

In die Zelle käme diese Formel:

=Zahl_Aufteilen_Regex(B6;"-"; 0)

Die benutzerdefinierten Funktionen in ein Standardmodul:

---

Getrennte Funktionen für Euro und Cent

Function WEuro(Zelle) If Not IsNumeric(Zelle) Then WEuro = "" Else WEuro = Fix(Zelle) End Function Function WCent(Zelle) If Not IsNumeric(Zelle) Then WCent = "" Else WCent = (Zelle - Fix(Zelle)) * 100 End Function

In die Zellen braucht man dann nur die Formeln einzugeben:

= WEuro(A1) = WCent(A1)

---

Eine Funktionen mit Wahlparameter für Euro oder Cent

Function EuroCent(Zelle, was) EuroCent = "" If IsNumeric(Zelle) Then EuroCent = IIf(was = 1, Fix(Zelle), (Zelle - Fix(Zelle)) * 100) End If End Function

In die Zellen käme dann
=eurocent(A1;1) für den Eurobetrag,
=eurocent(A1;2) für die Cent.

---

Dynamische Arrayformel mit Matrixfunktion (ab Excel 365)

In die Zelle wird dazu eingetragen:

=EuroCent_Beide(D1)

Mit diesem Add-In können Zeiten mit dem â??+â??-Zeichen statt des Doppelpunktes eingegeben werden. So kann die Hand beim Num-Block bleiben.

Hinweis:
Mit dem Add-In »Ribbonkalenderâ?? kann auch ein anderes Zeichen eingestellt werden; auÃ?erdem stehen noch weitere Datums- und Zeitfunktionen zur Verfügung.

Download: zeit_ohne_doppelpunkt.xlam

Soll das wirklich geschehen, geht es mit dem folgenden Code:

Application.SendKeys ("{F2}")

Allerdings wird bei SendKeys dummerweise der Numblock ausgeschaltet, so dass diese Tasten dann als Richtungstasten statt der Zahleneingaben funktionieren.

Generell ist es besser, Zellen Inhalte direkt zuzuweisen. Dann funktionieren etwaige Makros auch weiter, was im Bearbeitungsmodus unterbrochen wird. Bei automatisierten Eintragungen oder Ã?nderungen ist es eigentlich nie notwendig, in den Bearbeitungsmodus zu wechseln.

In ein Standardmodul folgende benutzerdefinierte Funktion:

Function Farbenzaehlen(Bereich) Dim Zelle As Object Application.Volatile Farbenzaehlen = 0 For Each Zelle In Bereich If Zelle.Interior.ColorIndex <> xlNone Then Farbenzaehlen = Farbenzaehlen + 1 Next End Function

Allerdings muss beachtet werden, dass eine Neuberechnung der Formel nicht erfolgt, wenn eine Hintergrundfarbe geändert wird. Hierzu muss irgendwo eine Eingabe erfolgen oder F9 gedrückt werden.

Sollte eine sofortige Neuberechnung wichtig sein, kann im Klassenmodul der Tabelle oder im Klassenmodul DieseArbeitsmappe das SelectionChange-Ereignis abgefangen werden:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.Calculate End Sub

Oder für die Mappe:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.Calculate End Sub

Allerdings wird dann wirklich bei jeder Bewegung neu berechnet, was sich bei vielen Formeln mit einer gewissen Trägheit bemerkbar machen kann.

Dazu gibt es verschiedene Möglichkeiten.

Direkt in Zellen eintragen

In der ersten Variante erfolgt die Arbeit direkt an den Zellen, weil hier die Funktionen Finden und Sortieren von Excel genutzt werden. Funktionen, die Excel zur Verfügung stellt, sind i. d. R. recht schnell, so dass das in diesem Fall sicher die kürzere und schnellere Variante ist:

Sub Zufall() Dim intWert As Integer, varWieviele, intI As Integer Dim bolVorhanden As Boolean, rngGef As Range varWieviele = InputBox("Wieviele Zahlen sollen erzeugt werden?", "Anzahl", 6) If Not IsNumeric(varWieviele) Then Exit Sub If varWieviele > 15 Then Exit Sub Sheets("Tab1").Range("A1:O1").ClearContents For intI = 1 To varWieviele intWert = Int((49 * Rnd) + 1) If intI = 1 Then Sheets("Tab1").Cells(1, intI) = intWert Else Do bolVorhanden = False Set rngGef = Range(Cells(1, 1), Cells(1, intI - 1)).Find(intWert) If Not rngGef Is Nothing Then bolVorhanden = True intWert = Int((49 * Rnd) + 1) End If Loop While bolVorhanden = True Sheets("Tab1").Cells(1, intI) = intWert End If Next Sheets("Tab1").Range("A1:O1").Sort Key1:=Sheets("Tab1").Range("A1"), Order1:=xlAscending, Orientation:=xlLeftToRight End Sub

Kern des Codes ist eine Schleife, die so lange läuft, wie eine Zufallszahl nicht mehr in den bisherigen Zufallszahlen gefunden wird. Erst dann wird sie als neue Zufallszahl verwendet.

Weiteres Beispiel - Schleife statt Find:

Sub Zufall() Dim intAnzahl As Integer, intMax As Integer, intMin As Integer Dim intWert As Integer, intI As Integer, intN As Integer Dim bolVorhanden As Boolean intAnzahl = 10 intMax = 49 intMin = 1 'alte Zahlen löschen Range(Cells(1, 2), Cells(intAnzahl, 2)).ClearContents Cells(1, 2) = Int((intMax * Rnd) + intMin) '1. Zahl erzeugen For intI = 2 To intAnzahl 'nächste Zahlen erzeugen Do bolVorhanden = False intWert = Int((intMax * Rnd) + intMin) For intN = 1 To intI 'Kontrolle ob schon vorhanden If Cells(intN, 2) = intWert Then bolVorhanden = True Exit For End If Next Loop While bolVorhanden = True Cells(intI, 2) = intWert 'Zahl eintragen Next End Sub

---

Erst Array, zum Schluss in Zellen

Manchmal kann die Arbeit mit Zellen aber auch von Nachteil sein. Deshalb ist hier der Vollständigkeit halber noch ein Beispiel, in dem Herangehensweisen mit einem Array aufgezeigt werden:

Sub Zufall1() Dim intWert As Integer, intI As Integer, intN As Integer, varWieviele Dim bolVorhanden As Boolean, bolSortiert As Boolean Dim arrZahlen() varWieviele = InputBox("Wieviele Zahlen sollen erzeugt werden?", "Anzahl", 6) If Not IsNumeric(varWieviele) Then Exit Sub If varWieviele > 15 Then Exit Sub ReDim Preserve arrZahlen(varWieviele) For intN = 0 To varWieviele - 1 intWert = Int((49 * Rnd) + 1) If intN = 0 Then arrZahlen(intN) = intWert Else Do bolVorhanden = False For intI = 0 To intN If arrZahlen(intI) = intWert Then bolVorhanden = True intWert = Int((49 * Rnd) + 1) Exit For End If Next Loop While bolVorhanden = True arrZahlen(intN) = intWert End If Next Do bolSortiert = True For intN = 0 To varWieviele - 2 If arrZahlen(intN + 1) < arrZahlen(intN) Then bolSortiert = False intWert = arrZahlen(intN + 1) arrZahlen(intN + 1) = arrZahlen(intN) arrZahlen(intN) = intWert End If Next Loop While bolSortiert = False Sheets("Tab1").Range("A1:O1").ClearContents For intN = 0 To varWieviele - 1 Sheets("Tab1").Cells(1, intN + 1) = arrZahlen(intN) Next End Sub

Das gesamte Erstellen der Zufallszahlen - bis hin zum Sortieren - erfolgt zunächst in einem Array. Auch hier erfolgt die Prüfung auf Doppelungen. Aber es ist zu sehen, dass dafür eine weitere Schleife eingebaut ist. Eine Funktion wie in PHP in_array() wäre da natürlich günstiger.

Auch zum Sortieren wird die innere Schleife so lange durchlaufen, bis im Array das nächste Element nicht kleiner als das gerade durchlaufene Element ist.

Erst ganz zum Schluss wird der fertige Array in die Zellen übernommen.

Die zweite Variante hat den Vorteil, dass sie beliebig - und unabhängig von Zellen - eingesetzt werden kann. Sie kann auch als eigenständige Funktion erstellt werden, die dann den Array mit den Zufallszahlen zurückgibt. So könnte die Funktion von überall aufgerufen werden; in die Zellen würde dann das Ergebnis eingetragen.

Oft stö�t man bei Schleifen, die Zellen lesen und schreiben, auf das Problem, dass die Laufzeit enorm steigt. Deshalb sollte zumindest in Betracht gezogen werden, das Ganze mit Arrays zu erledigen und die Zellzugriffe auf ein Minimum zu beschränken.

---

Dynamische Arrayformel mit Matrixfunktion (ab Excel 365)

Natürlich kann das auch als Matrixfunktion für eine dynamische Arrayformel erstellt werden. Die Funktion erstellt einen Array mit eindeutigen Zahlen. Zum Schluss wird mit der Arrayfunktion SORTIEREN() sortiert und der Array ausgegeben.

Function Zufallszahlen_Eindeutig(ByVal intAnzahl As Integer, ByVal intMin As Integer, ByVal intMax As Integer) Dim intWert As Integer, intI As Integer, intN As Integer Dim bolVorhanden As Boolean, arrZahlen() Application.Volatile ReDim Preserve arrZahlen(1 To intAnzahl) For intN = 1 To intAnzahl intWert = Int((intMax * Rnd) + intMin) If intN = 1 Then arrZahlen(intN) = intWert Else Do bolVorhanden = False For intI = 1 To intN If arrZahlen(intI) = intWert Then bolVorhanden = True intWert = Int((intMax * Rnd) + intMin) Exit For End If Next Loop While bolVorhanden = True arrZahlen(intN) = intWert End If Next Zufallszahlen_Eindeutig = Application.WorksheetFunction.Sort(arrZahlen, 1, 1, 1) End Function

In die Zelle kommt einfach:

=Zufallszahlen_Eindeutig(Anzahl;Minimum;Maximum)

=Zufallszahlen_Eindeutig(5;1;49)

Sollen die Zahlen untereinander erscheinen, kann die Funktion in MTRANS() gesetzt werden:

=MTRANS(Zufallszahlen_Eindeutig(5;1;49))

Die Funktion ZUFALLSMATRIX() klingt danach, als ob sie die Aufgabe auch erfüllen könnte. Jedoch hat sie bei dieser Aufgabenstellung den gro�en Nachteil, dass sie sehr häufig mehrfach vorhandene Zahlen erzeugt. Das hei�t, dass man so oft berechnen lassen müsste, bis jede Zahl eindeutig ist - und das kann etwas dauern.

Apropos eindeutig: Mit der Funktion EINDEUTIG() könnte natürlich geprüft werden, ob eindeutige Zufallszahlen vorliegen. Allerdings ist die Funktion manchmal schneller als die Sortieren-Funktion, so dass letztere Funktion noch rechnet, wenn EINDEUTIG() schon fertig ist. Das führt dann zum bekannten Fehler �BERLAUF.