Datenschutzerklärung


Direktnachricht



Ihre Software
Details
Excel/VBA 🔍
Add-Ins
Excel/VBA

Excel-Beispiele:
Erklärungen, Formeln, VBA-Code und mehr

Hinweise zu den Beispielen finden Sie hier: Beispiele


Dateiname aus Pfad (Dir(), Regulärer Ausdruck, Arrayformel)Makro/Sub/ProzedurUDF - benutzerdefinierte FunktionFormellösungArrayfunktion/Matrixfunktion

Kategorien: Dateien und Ordner ▸ Dateien und Stringoperationen ▸ Teile

(Tipp 24) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich aus einem Pfad (z. B. bei GetOpenFileName) den Dateinamen (bzw. Ordner) filtern?

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).

Erster Buchstabe in Zeichenfolge (auch mit Regex)UDF - benutzerdefinierte Funktion

Kategorie: Stringoperationen ▸ Teile

(Tipp 173) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich den ersten Buchstaben in einer Zeichenfolge auslesen lassen?

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.

Kommagetrennte Vornamen zählen (mit Arrayfunktionen)UDF - benutzerdefinierte FunktionArrayfunktion/Matrixfunktion

Kategorien: Tabelle ▸ Zellen und Stringoperationen ▸ Teile

(Tipp 138) Nachricht zum Beitrag an Autor Nach oben

In einigen Zellen stehen mehrere Vornamen, durch ein Komma getrennt. Wie kann ich die Vornamen unter dem Datenbereich auswerten lassen? Beispiel: Tobias, Jens Ingo Frank, Tobias Ingrid, Sabine

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.

Numerische und alphanumerische Werte sortieren (mit Regex)Makro/Sub/ProzedurUDF - benutzerdefinierte Funktion

Kategorien: Filter/Sortieren und Stringoperationen ▸ Teile

(Tipp 140) Beispieldatei Nachricht zum Beitrag an Autor Nach oben

Wie kann ich folgende Zahlen in Spalte A sortieren: 100, 101, 100a, 100b, 102? Dazwischen befinden sich keine leeren Zellen.

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


Microsoft VBScript Regular Expressions

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

String aufteilenUDF - benutzerdefinierte Funktion

Kategorie: Stringoperationen ▸ Teile

(Tipp 567) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich einen String aufgrund eines Trennzeichens aufteilen?

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

In Zelle B1 steht der String Januar;Februar;März, in C1 steht die Formel =Stringteile(B1;";"). Die Monate werden durch die Funktion also am Semikolon gesplittet und die Funktion gibt das Ganze als Array zurück. Da es sich aber um drei Elemente handelt (eben die drei Monate), werden diese auf die Nachbarzellen ausgeweitet; die Zelle mit der Formel fließt über.

Wird jedoch der implizite Schnittpunktoperator @ verwendet (also =@Stringteile(B1;";")), wird nur das erste Element des Arrays zurückgegeben, also der Januar.

In jedem Fall kann aus einer anderen Formel heraus Bezug auf eine Ergebniszelle genommen werden. Im Beispiel auch auf E1, wo das Element März steht.


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.

Teil einer Zelle mit Text verbindenFormellösung

Kategorien: Stringoperationen ▸ Teile und Stringoperationen ▸ Verketten

(Tipp 184) Nachricht zum Beitrag an Autor Nach oben

In Zeile 1 stehen in den Zellen Vornamen und Namen, in Zeile 2 die zugehörigen Anreden. Wie kann ich erreichen, daß in einer anderen Zelle nur die Anrede mit dem Nachnamen erscheint?

=A2&" "&RECHTS(A1; LÄNGE(A1)-FINDEN(" ";A1))



Teil eines Datums einlesen (VBA + Formel + Format)UDF - benutzerdefinierte FunktionFormellösung

Kategorien: Stringoperationen ▸ Teile und Format ▸ Datum

(Tipp 177) Nachricht zum Beitrag an Autor Nach oben

Wie kann man von einem Datum in einer anderen Zelle nur die ersten zwei Zahlen und den Punkt angezeigt bekommen, also Tag.?

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)

Vornamen und Nachnamen trennenMakro/Sub/ProzedurUDF - benutzerdefinierte FunktionTipp

Kategorie: Stringoperationen ▸ Teile

(Tipp 124) Nachricht zum Beitrag an Autor Nach oben

In einem markierten Bereich befinden sich in jeweils einer Zelle Vornamen und Nachnamen, die durch Leerstellen getrennt sind. Wie kann ich Vornamen und Nachnamen in die Nachbarzellen einlesen lassen?

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.

Zahlen zerlegen in Euro + Cent (in zwei Zellen)UDF - benutzerdefinierte Funktion

Kategorie: Stringoperationen ▸ Teile

(Tipp 166) Nachricht zum Beitrag an Autor Nach oben

Wie kann man einen Betrag in Eurobetrag und Centbetrag trennen? Aus 3,25 Euro müsste in der einen Zelle die 3, in der anderen Zelle die 25 stehen.

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)

Die folgende Funktion gibt beide Werte, also Euro und Cent, als Datenfeld zurück:

Function EuroCent_Beide(Zelle) Dim arrTemp(1 To 2) Application.Volatile arrTemp(1) = "" arrTemp(2) = "" If Zelle <> "" And IsNumeric(Zelle) Then arrTemp(1) = Fix(Zelle) arrTemp(2) = (Zelle - Fix(Zelle)) * 100 End If EuroCent_Beide = arrTemp End Function

In die Zelle wird dazu eingetragen:

=EuroCent_Beide(D1)

Zelleinträge trennenTipp

Kategorie: Stringoperationen ▸ Teile

(Tipp 244) Nachricht zum Beitrag an Autor Nach oben

In einem Zellbereich stehen in den einzelnen Zellen Vor und Nachnamen. Wie kann ich diese Einträge ohne VBA trennen, so dass in einer Zelle der Vor- und in der Nachbarzelle der Nachname erscheint?

Zunächst sollte man hinter der Spalte, welche die Daten (also Vor- und Nachname) enthält, eine neue Spalte einfügen. Danach ist folgendes Vorgehen möglich:

  1. Entsprechenden Bereich (oder auch die gesamte Spalte) markieren.
  2. Ribbon Daten aufrufen.
  3. Eintrag Text in Spalten wählen, ein Assistent wird gestartet.
  4. Der Eintrag Getrennt muss aktiviert sein.
  5. Mit der Schaltfläche Weiter gelangt man in den zweiten Schritt des Assistenten.
  6. Leerzeichen wählen.
  7. Mit der Schaltfläche Weiter erhält man eine Vorschau.
  8. Mit Fertigstellen die Aktion beenden.

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 darauf achten, vor der Ausführung des Befehls entsprechend viele Spalten einzufügen.