Suchergebnisse (12 Treffer, 1 Begriff) 
Kategorie: Tabelle ▸ Zellen
Wie kann ich die Zelladresse bzw. die Zeilen-/Spaltennummer der aktiven Zelle über Makro feststellen lassen?
Hier sind ein paar Beispiele zur Arbeit mit den Zellangaben der gerade aktiven Zelle:
Sub Zelladresse() With ActiveCell MsgBox .Address MsgBox .Address(False) MsgBox .Address(, False) MsgBox .Address(False, False) MsgBox .Row MsgBox .Column MsgBox "Zeile: " & .Row & " - Spalte:" & .Column End With End Sub
Kategorie: Tabelle ▸ Zellen
Wie kann ich mit Formeln eine Rechnung erstellen?
Du hast eine Tabelle namens "Rechnung" und eine Tabelle namens "Artikel". Auf der Tabelle "Artikel" befinden sich ab A2 die Artikelnummern (hier fortlaufend numeriert), ab B2 die Artikel und ab C2 die Einzelpreise. Auf dem Blatt "Rechnung" wird die Rechnung erstellt.:
Kategorie: Mappe ▸ Tabellen
Die Tabellenblätter einer Mappe sind mit Tab1, Tab2, ..., Tab50, Tab51, usw. durchnummeriert. Wie kann ich sie sortieren?
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
Kategorien: Dateien und Ordner ▸ Dateioperation und Dateien und Ordner ▸ Dokumenteigenschaften
Wie kann man in einer Datei eine fortlaufende Nummer speichern?
Die Nummer in eine Zelle schreiben, die auch ausgeblendet werden kann. Dann bei jedem Speichern die Nummer mit z. B. Range("A1") = Range("A1") + 1 erhöhen.
Die CustomDocumentProperties der Datei können auch mit VBA-Code verwendet werden. Dann wird die Nummer versteckt in dieser Datei gespeichert:
Dazu einmalig die Eigenschaft mit der folgenden Zeile erstellen:
ThisWorkbook.CustomDocumentProperties.Add Name:="lfdNr", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=0
Anzeigen kann man den Wert, der neu 0 ist, mit der Zeile:
MsgBox ThisWorkbook.CustomDocumentProperties("lfdNr").Value
Erhöht wird der der Wert mit
ThisWorkbook.CustomDocumentProperties("lfdNr").Value = ThisWorkbook.CustomDocumentProperties("lfdNr").Value + 1
Nach dem Erhöhen des Wertes nicht vergessen, die Datei zu speichern. Auch wenn diese Eigenschaften nicht sichtbar sind, sind sie doch in der Datei enthalten.
Oder die Nummer in eine Datei auslagern, zum Beispiel so:
Sub lfdNr() Dim lngDNr As Long, intNr As Integer Dim strDName As String, strZielordner As String, strDateiname As String strZielordner = ThisWorkbook.Path & "\" 'Hier den Pfad verändern strDateiname = "Excel_lfdNr" 'Hier den Dateinamen verändern strDName = strZielordner & strDateiname & ".ini" intNr = 0 lngDNr = FreeFile If Dir(strDName) <> "" Then Open strDName For Input As #lngDNr Input #lngDNr, intNr Close #lngDNr End If intNr = intNr + 1 lngDNr = FreeFile Open strDName For Output As #lngDNr Print #lngDNr, intNr; Close #lngDNr ActiveCell.Value = intNr End Sub
Kategorie: Format ▸ Farben
Wie kann ich die Excel-Farbnummern auflisten lassen?
Dieses Makro fügt die Nummern in Spalte E ein und "färbt" in der Spalte F.
Sub Farben() Dim intZ As Integer For intZ = 1 To 56 Cells(intZ, 5) = intZ Cells(intZ, 6).Interior.ColorIndex = intZ Next End Sub
Excel kann jedoch mit wesentlich mehr Farben umgehen, nämlich auch den RGB-Farben. Die kann man natürlich nicht alle auflisten, weil Excel in einer Mappe nur begrenzt Zellformate haben kann. Aber man kann Bereiche darstellen, zum Beispiel so:
Sub Farben1() Dim lngZ As LongPtr, intS As Integer, lngF As Long Dim lngStart As LongPtr Dim datBeg As Date Workbooks.Add ActiveSheet.Columns.ColumnWidth = 5 ActiveWindow.Zoom = 10 intS = 2 lngZ = 0 lngStart = 9895936 On Error GoTo FEHLER For lngF = lngStart To lngStart + 65279 lngZ = lngZ + 1 Cells(lngZ, intS) = lngF Cells(lngZ, intS).Interior.Color = lngF '65430 If lngZ Mod 256 = 0 Then intS = intS + 1 lngZ = 0 End If Next MsgBox Format(Now - datBeg, "mm:ss") Exit Sub FEHLER: MsgBox "Abbruch bei " & lngF & vbNewLine & "Fehler: " & Err.Number & vbNewLine & Err.Description End Sub
Mit der Zahl in lngStart kann einfach experimentiert werden.
Möglich ist auch, mit den RGB-Werten direkt zu arbeiten. Alle auf einmal verkraftet Exel nicht, also muss hier entweder mit Step oder durch kleinere Abbruchwerte reduziert werden:
Sub Farben2() Dim lngZ As LongPtr, intS As Integer, strRGB As String Dim datBeg As Date Dim r As Integer, g As Integer, b As Integer Workbooks.Add ActiveSheet.Columns.ColumnWidth = 5 ActiveWindow.Zoom = 10 intS = 2 lngZ = 0 On Error GoTo FEHLER For r = 0 To 255 Step 10 For g = 0 To 255 Step 7 For b = 0 To 255 Step 5 lngZ = lngZ + 1 strRGB = r & "|" & g & "|" & b 'Cells(lngZ, intS) = strRGB Cells(lngZ, intS).Interior.Color = RGB(r, g, b) If lngZ Mod 256 = 0 Then intS = intS + 1 lngZ = 0 End If Next Next Next MsgBox Format(Now - datBeg, "mm:ss") Exit Sub FEHLER: MsgBox "Abbruch bei " & strRGB & vbNewLine & "Fehler: " & Err.Number & vbNewLine & Err.Description End Sub
Die zweite Variante ist wahrscheinlich die optisch schönste, die ergibt solche Verläufe:
Kategorien: Datum/Zeit ▸ Datum und Tabelle ▸ Matrix
Auf verschiedenen Blättern einer Mappe befinden sich in Spalte E Namen, in Spalte F Geburtstage und in Spalte J Telefonnummern. Wie kann ich die Geburtstagskinder des heutigen Tages in einer UserForm-Listbox anzeigen lassen?
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:
Das grundlegende Vorgehen ist hier wie bei der älteren Variante (siehe unten), nur beim Sammeln der Daten wird die Tabellenblattfunktion FILTER() verwendet. Die Blätter werden also auch einzeln abgearbeitet, pro Blatt arbeitet aber diese Funktion. Wir gehen hier davon aus, dass der Datenbereich ab Zeile 3 und ab Spalte C beginnt.
Die Funktion sorgt dafür, dass nicht jede Zeile auf dem Blatt durchlaufen werden muss, sondern dass bereits eine Ergebnismenge vorhanden ist - es müssen also weniger Daten ausgewertet werden. Sie liefert einen Array, in dem die Zeilen enthalten sind, in denen sich die gefundenen Geburtstage befinden. Die einzelnen Daten sind Elemente jeder Zeile, der Geburtstag ist das vierte Element (ab Spalte C). Die Datumsangaben liegen in diesem Array als Long-Zahlen vor, deshalb sind sie hier noch formatiert.
Für den praktischen Einsatz kann es notwendig sein, die Blätter noch etwas einzugrenzen, weil sonst Fehler auftreten könnten. Hier wird mit IsArray() geprüft, ob ein Array vorliegt, fürs Grobe reicht das erst mal. Die Routine:
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
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
Kategorie: Tabelle ▸ Grafik
Auf einem Tabellenblatt befinden sich mehrere Symbole, die mit Bild ... durchnumeriert sind. Wie kann ich erreichen, daÃ? auf der Grundlage einer in B2 stehenden Zahl die entsprechende Grafik nach C2 kopiert wird?
Auf dem Tabellenblatt sind also mehrere Grafiken, deren Namen den Aufbau Bild x haben, wobei X für eine Zahl steht. In B2 soll diese Zahl eingetragen werden. Das entsprechende Bild soll dann auf C2 kopiert werden.
Der Code prüft zunächst, ob ein Bild mit dem Namen Symbol vorhanden ist. Wenn ja wird es gelöscht. Anschlie�end wird das Bild mit der jeweiligen Nummer kopiert, eingefügt, an C2 ausgerichtet und mit dem Namen Symbol versehen.
Sub Symbol_einfuegen() Dim strSymbol As String Dim shpSymb As Shape For Each shpSymb In ActiveSheet.Shapes If shpSymb.Name = "Symbol" Then shpSymb.Delete Next strSymbol = "Bild " & ActiveSheet.Range("B2").Value ActiveSheet.Shapes(strSymbol).CopyPicture xlScreen, xlBitmap With ActiveSheet.Pictures.Paste .Top = .Parent.Range("C2").Top .Left = .Parent.Range("C2").Left .Name = "Symbol" End With End Sub
Kategorien: Filter/Sortieren und Stringoperationen ▸ Teile
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.
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
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
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
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.
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
Kategorien: Tabelle ▸ Zellen und Berechnungen
Wie kann man die Quersumme einer Zahl in einer Zelle bilden?
Function Quersumme(Zelle As Range) As Integer Dim intI As Integer Application.Volatile Quersumme = 0 If IsNumeric(Zelle) Then For intI = 1 To Len(Zelle) Quersumme = Quersumme + CInt(Mid(Zelle, intI, 1)) Next End If End Function
In die Zellen braucht man dann nur die Formel einzugeben:
=Quersumme(A1)
Eine interessante Lösung per Formel, die die Zeilennummern verwendet, finden Sie hier: exceltricks.blog.
Kategorie: Tabelle ▸ Zellen
Wie kann ich in einer Formel einen Teil des Zellbezugs (z. B. Zeilennummer) aus einer anderen Zelle übernehmen?
In A2 steht die Zeilennummer des in der Formel zu verwendenden Zellbezugs:
=INDIREKT("C"&A2)
Wenn in A2 zum Beispiel eine 3 stehen würde, wäre die Formel identisch mit =C3
Kategorien: Ereignisse ▸ Tabellen und Datum/Zeit ▸ Zeit
Ein Datum kann man auf der Nummerntastatur mit einem Minus eingeben: 12-10-99 für den 12.10.99. Geht das auch mit der Uhrzeit und wie?
Eine Lösung per Zahlenformatierung (00":"00) ist nicht empfehlenswert. Die Zahlen sehen zwar wie Uhrzeiten aus, ein Weiterrechnen mit diesen "Zeiten" ist aber nicht möglich. Besser ist eine Makrolösung, die automatisch eine eingegebene Zahl in eine Uhrzeit umwandelt.
Ein Klassenmodul »Klasse1« einfügen, dort diesen Code eingeben:
Public WithEvents Anwendung As Application Private Sub Anwendung_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim bolEvents As Boolean, intI As Integer, varZeit As Variant, arrTemp If Target.Cells.Count > 1 Then Exit Sub If Target = "" Then Exit Sub If Target.HasFormula Then Exit Sub If InStr(1, Target, "+") = 0 Then Exit Sub arrTemp = Split(Target, "+") If UBound(arrTemp) > 2 Then Exit Sub varZeit = "" For intI = 0 To UBound(arrTemp) varZeit = varZeit & arrTemp(intI) & IIf(intI < UBound(arrTemp), ":", "") Next If IsDate(varZeit) Then Target = varZeit Application.EnableEvents = bolEvents End Sub
In »DieseArbeitsmappe« diesen Code einfügen:
Dim Anwendungsobjekt As New Klasse1 Private Sub Workbook_Open() Set Anwendungsobjekt.Anwendung = Application End Sub
Immer dann, wenn diese Mappe offen ist, können Sie Zeiten mit dem Pluszeichen eingeben. Empfehlenswert ist, diese Mappe als Add-In zu speichern. Ein fertiges finden Sie hier: Downloads
Kategorie: Tabelle ▸ Zellen
Wie kann ich per Makro die Zellbearbeitung aktivieren, so daÃ? der Cursor in der Zelle blinkt?
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.