Software für Sie.

Zum Sortieren der Blätter gibt es verschiedene Möglichkeiten, was auch etwas von den Rahmenbedingungen abhängig ist. Was soll zum Beispiel mit Blättern passieren, deren Namen nicht der Syntax der zu sortierenden Blattnamen entsprechen? Hier sind drei Beispiele, die ggf. noch angepasst werden müssen.

In dem Fall werden unterwegs (also nicht am Anfang) Blätter mit Namen, die nicht der Syntax entsprechen, nach hinten verschoben - ansonsten wird so lange sortiert, bis die Zahl im folgenden Blattnamen nicht mehr gö�er ist:

Sub BlaetterSortieren() Dim bolSortiert As Boolean Dim intBlatt As Integer, intBlatt1 As Integer Dim varAkt, varNaechst bolSortiert = False Do While bolSortiert = False bolSortiert = True For intBlatt = 1 To Sheets.Count varAkt = Replace(Sheets(intBlatt).Name, "Tab", "") If IsNumeric(varAkt) Then For intBlatt1 = intBlatt To Sheets.Count varNaechst = Replace(Sheets(intBlatt1).Name, "Tab", "") If IsNumeric(varNaechst) Then If varNaechst * 1 < varAkt * 1 Then Sheets(intBlatt1).Move Before:=Sheets(intBlatt) bolSortiert = False End If Else Sheets(intBlatt1).Move after:=Sheets(Sheets.Count) End If Next End If Next Loop End Sub

Ein Beispiel mit Sprungmarken, Reihenfolge Tab1, Tab2, Tab11:

Sub Blattsort() Dim intAnzahl As Integer, intN As Integer, intM As Integer, intI As Integer, intZahlM As Integer, intZahlN As Integer Dim WS As Worksheet intAnzahl = ActiveWorkbook.Worksheets.Count For intM = 1 To intAnzahl For intN = intM To intAnzahl On Error Resume Next For intI = 1 To Len(Worksheets(intN).Name) If IsNumeric(Right(Worksheets(intN).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlN = Right(Worksheets(intN).Name, intI) Exit For End If Next intI For intI = 1 To Len(Worksheets(intM).Name) If IsNumeric(Right(Worksheets(intM).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlM = Right(Worksheets(intM).Name, intI) Exit For End If Next intI If CInt(intZahlN) < CInt(intZahlM) Then Worksheets(intN).Move Before:=Worksheets(intM) GoTo NAECHSTE TEXT: If Worksheets(intN).Name < Worksheets(intM).Name Then Worksheets(intN).Move Before:=Worksheets(intM) NAECHSTE: Next intN Next intM MsgBox "Anzahl der Tabellen: " & intAnzahl End Sub

Ein kurzes Beispiel, aber die Reihenfolge ist Tab1, Tab11, Tab2:

Sub Blattsort1() Dim intX As Integer Dim bolY As Boolean Do bolY = True For intX = 1 To Sheets.Count - 1 If Sheets(intX).Name > Sheets(intX + 1).Name Then Sheets(intX + 1).Move Before:=Sheets(intX) bolY = False End If Next intX Loop Until bolY = True End Sub

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

Wenn vorher bekannt ist, wie viele Unterstriche enthalten sein können, kann das verwendet werden:

Sub Unterstriche() Dim intI As Integer Application.ScreenUpdating = False '10 = maximale Zahl der Unterstriche For intI = 1 To 10 Range("A1:A65536").Replace What:="__", Replacement:="_", LookAt:=xlPart, SearchOrder:=xlByRows Next Range("A1").Select Application.ScreenUpdating = True End Sub

Ansonsten kann auch eine While-Schleife so lange laufen, wie noch doppelte Unterstriche gefunden werden:

Dim objGef As Object Set objGef = Cells.Find("__") Do While Not objGef Is Nothing Cells.Replace "__", "_" Set objGef = Cells.Find("__") Loop

Variante mit regulären Ausdrücken:

Sub Doppelte_Unterstriche() Dim strRepl As String, rngZelle As Range Dim Regex As Object, regMatches, regMatch If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") strRepl = "_" Regex.Global = True Regex.Pattern = "(__+)" For Each rngZelle In ActiveSheet.UsedRange Set regMatches = Regex.Execute(rngZelle) rngZelle = Regex.Replace(rngZelle, strRepl) Next Set Regex = Nothing End Sub

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.

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

Die integrierten Dialogfelder von Excel können auch mit VBA aufgerufen werden. Dies geschieht einfach mit:

Application.Dialogs(Konstante).Show

Bei den Dialogfeldern können verschiedene Argumente mitgegeben werden, die natürlich bei jedem Element anders sind. Hierzu am besten einfach in die Hilfe sehen.

Manchmal muss man sich entscheiden, ob ein integriertes Dialogfeld oder ein herkömmliches Dialogfeld für die Aufgabe besser geeignet ist. Mit z. B. Application.GetOpenFilename kann schön der Pfad abgefragt werden, was mit xlDialogOpen schon nicht mehr so einfach ist.

Download: integrierte_dialogfelder.xlsm

Beispiel 1:

Sub Minus() Dim lngZ As Long, lngS As Long, strMZahl As String lngS = 2 'Spalte mit Zahlen For lngZ = 2 To 20 On Error Resume Next strMZahl = Cells(lngZ, lngS) If Right(strMZahl, 1) = "-" Then Cells(lngZ, lngS) = "-" & Replace(strMZahl, "-", "") Next End Sub

Beispiel 2:

Sub Minus() Dim lngZ As Long, lngS As Long, strMZahl As String lngS = 2 'Spalte mit Zahlen For lngZ = 2 To 20 On Error Resume Next strMZahl = Cells(lngZ, lngS) If Right(strMZahl, 1) = "-" Then Cells(lngZ, lngS) = "-" & Left(strMZahl, Len(strMZahl) - 1) Next End Sub

Beispiel 3 als Formeln:

=WENN(RECHTS(A1;1)="-";("-"&LINKS(A1;LÃ?NGE(A1)-1))*1;A1)

=WENN(RECHTS(A1;1)="-";(-1)*LINKS(A1;LÃ?NGE(A1)-1);1*A1)

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

Vor das Sternchen setzt man einfach eine Tilde ~.

Sub Stern_ersetzen() Cells.Replace "~*", "", xlWhole End Sub

In Inputboxen werden zu suchender Text und neuer Text eingegeben. Anschlie�end wird auf jedem Tabellenblatt der Mappe die Ersetzung durchgeführt.

Sub suchersetz() Dim strSuchBegriff As String, strErsetzBegriff As String Dim wks As Worksheet strSuchBegriff = Application.InputBox("Bitte den zu suchenden Begriff eingeben") strErsetzBegriff = Application.InputBox("Bitte den Ersatzbegriff eingeben") For Each wks In ActiveWorkbook.Worksheets wks.UsedRange.Replace what:=strSuchBegriff, replacement:=strErsetzBegriff, lookat:=xlPart, searchOrder:=xlByColumns, MatchCase:=False Next End Sub

Ggf. kann hier noch eine Fehlerbehandlung eingebaut werden, wenn zum Beispiel eine InputBox abgebrochen wurde.

Es gibt verschiedene Möglichkeiten. Ein zweidimensionaler Array würde nahe liegen, aber mit dieser Variante ist es etwas kürzer.

Wandelt Umlaute und das Ã? in Selbstlaute um:

Sub InSelbstlaute() Dim arrSuchen(), arrErsetzen(), intI As Integer arrSuchen = Array("�", "�", "�", "ö", "ä", "ü", "�") arrErsetzen = Array("Oe", "Ae", "Ue", "oe", "ae", "ue", "ss") For intI = 0 To UBound(arrSuchen) Range("A5:C10").Replace What:=arrSuchen(intI), Replacement:=arrErsetzen(intI), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True Next End Sub

Die Schleife läuft über den ersten Array und ersetzt im Range das gerade durchlaufene Zeichen durch den String, der im zweiten Array an der gleichen Stelle ist.

Wandelt Selbstlaute und ss in Umlaute um:

Sub InUmlaute() Dim arrSuchen(), arrErsetzen(), intI As Integer arrSuchen = Array("Oe", "Ae", "Ue", "oe", "ae", "ue", "ss") arrErsetzen = Array("�", "�", "�", "ö", "ä", "ü", "�") For intI = 0 To UBound(arrSuchen) Range("A5:C10").Replace What:=arrSuchen(intI), Replacement:=arrErsetzen(intI), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True Next End Sub

Mit dem â??ssâ?? muss man natürlich aufpassen, das darf nicht mehr generell ersetzt werden. Hier muss also je nach Situation bzw. Anforderungen verfahren werden.

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)

Dieser Code ersetzt das unsichtbare Zeichen mit einem Mal in allen Zellen der aktiven Tabelle:

Sub ZeilenumbruecheErsetzen() ActiveSheet.Cells.Replace Chr(10), " " End Sub