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


Kategorie: Beispiel > Excel > VBA > Tabelle (37)

Adresse der aktiven Zelle über VBA-Makro feststellen

(Tipp 12) Nachricht zum Beitrag an Autor Nach oben

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

Wert in erste leere Zelle eintragen

(Tipp 13) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich einen Zellwert in die erste leere Zelle eines vorgegebenen Bereiches eintragen lassen?

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.

Zellbezug in Fußzeile

(Tipp 122) Nachricht zum Beitrag an Autor Nach oben

Habe ich eine Möglichkeit, einen Zellbezug in die Kopf-/Fußzeile einzugeben? Z. B. in der Fußzeile soll immer der aktuelle Inhalt der Zelle A1 stehen?

Mit VBA kann natürlich auch der Inhalt einer Zelle verwendet werden. Am kürzesten geht es so, wenn A1 der aktiven Tabelle der aktiven Mappe verwendet werden soll:

ActiveSheet.PageSetup.LeftFooter = Range("A1")



Vornamen und Nachnamen trennen

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

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

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

Laufende Uhrzeit in Zelle

(Tipp 126) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich in einer Zelle immer die aktuelle Uhrzeit anzeigen?

Dazu nutzen wir drei verschiedene Routinen. Da der Vorgang aber immer weiter läuft, müssen wir dafür sorgen, dass wir den notfalls abbrechen können. Dazu deklarieren wir eine Variable am Anfang des Moduls:

Private bolC As Boolean

Die erste Sub ZeitFestLegen setzt diese Variable auf True und sorgt dafür, dass es in einer Sekunde losgeht, dass dann nämlich die Routine Eintragen gestartet wird:

Sub ZeitFestLegen() Dim datZeitAngabe As Date bolC = True datZeitAngabe = Time + TimeSerial(0, 0, 1) Application.OnTime datZeitAngabe, "Eintragen" End Sub

Diese Routine Eintragen trägt die Zeit in B2 ein und ruft, wenn bolC immer noch True ist, wieder ZeitFestLegen auf, die dafür sorgt, dass sich das Ganze nach einer Sekunde wiederholt:

Sub Eintragen() Range("B1") = Time If bolC = True Then ZeitFestLegen End Sub

Und so wird die Zeit eingetragen und eingetragen und eingetragen und …

Was aber, wenn wir das nicht mehr wollen, also den Vorgang anhalten möchten? Dafür nehmen wir eine kleine Sub, die die Variable bolC auf False setzt. Damit wird dann keine neue Zeit festgelegt, der Vorgang ist beendet.

Sub Notstopp() bolC = False End Sub

Die letzte Routine kann zum Beispiel an einen Button gebunden werden.

Pfad und Dateiname in die Fußzeile

(Tipp 127) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich Pfad und Dateinamen in die Fußzeile links einfügen?

Sub Pfad() ActiveSheet.PageSetup.LeftFooter = ActiveWorkbook.path & "\" & ActiveWorkbook.Name End Sub

Grafik auswählen und auf eine bestimmte Zelle legen

(Tipp 129) Nachricht zum Beitrag an Autor Nach oben

Auf einem Tabellenblatt befinden sich mehrere Gefahrengrafiken, 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

Erste leere Zelle in einer Spalte

(Tipp 130) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich in Spalte B die erste leere Zelle finden? Zwischen den Daten befinden sich keine leeren Zellen.

Entweder:

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

oder:

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

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

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

Zellwert um 1 erhöhen

(Tipp 131) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich den Wert von A1 um 1 erhöhen?

Sub Zaehler() Range("A1") = Range("A1") + 1 End Sub

Formeln in Zellen per VBA einfügen

(Tipp 132) Nachricht zum Beitrag an Autor Nach oben

Wie kann man in einer Tabelle in verschiedene Spalten Formeln mit Hilfe eines Makros hineinkopieren ? Dabei ist die „Startzeile“ immer die selbe. Dagegen variiert die „Endzeile“ in Abhängigkeit der eingegebenen Daten.

Angenommen in Spalte A und B stehen Zahlen, in Spalte C sollen jeweils die Summenformeln stehen. Die Zeilenanzahl wird durch die Spalte B bestimmt.

Variante mit englischer Syntax:

Sub Formeleinfuegen() Dim lngI As LongPtr For lngI = 1 To Cells(Rows.Count, 2).End(xlUp).Row ActiveSheet.Range("C" & lngI).Formula = "=SUM(A" & lngI & ",B" & lngI & ")" Next End Sub

Variante mit deutscher Syntax:

Sub Formeleinfuegen1() Dim lngI As LongPtr For lngI = 1 To Cells(Rows.Count, 2).End(xlUp).Row ActiveSheet.Range("C" & lngI).FormulaLocal = "=SUMME(A" & lngI & ";B" & lngI & ")" Next End Sub

Tabellenblatt löschen

(Tipp 133) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich ein Tabellenblatt löschen und die Excelmeldung ausschalten?

Sub TabellenBlattLöschen() Application.DisplayAlerts = False Sheets("MeinBlatt").Delete Application.DisplayAlerts = True End Sub

Tabellenblattnamen

(Tipp 134) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich den Tabellenblatt-Namen über Makro auslesen?

Sub TabellenblattName() MsgBox ActiveSheet.Name End Sub

Zeichen zu Zellinhalt hinzufügen

(Tipp 135) Nachricht zum Beitrag an Autor Nach oben

Wie füge ich an mehrere Zellen mit einen beliebigen Zellinhalt mehrere, gleichbleibende Zeichen (am Anfang oder Ende) hinzu?

In VBA z.B. für Spalte A

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

Möglichkeit per Formel:

="abc " & A1 & "def"

Anzahl der Einträge in einer Spalte

(Tipp 136) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich die Anzahl der Einträge in einer Spalte feststellen?

Wenn nur die letzte Zeile festgestellt werden soll:

Sub letzteZeile() MsgBox Cells(Rows.Count, 1).End(xlUp).Row End Sub

Zellen mit Inhalt:

Sub ZellenZaehlen() Dim intI As Integer, rngZelle As Range intI = 0 For Each rngZelle In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Cells If rngZelle.Value <> "" Then intI = intI + 1 Next MsgBox intI End Sub

Formel:

=ANZAHL2(C1:C8)

VBA mit Nutzung der der Worksheetfunction:

MsgBox Application.WorksheetFunction.CountA(Range("C2:C20"))



Minuszeichen nach vorn

(Tipp 137) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich in einer Spalte aus Zahlen, hinter denen das Minuszeichen steht, negative Zahlen erstellen?

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

Zufallszahlen in einem bestimmten Bereich generieren

(Tipp 139) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich zwischen 6 und 15 Zufallszahlen zwischen 1 und 49 generieren? Die Zahlen sollen auf dem Blatt Tab1 in der Zeile 1 ab A1 stehen. Keine Zahl darf sich wiederholen.

Dazu gibt es verschiedene Möglichkeiten. 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.

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.

Insgesamt dürfte die zweite Variante länger brauchen als die erste. Allerdings hat sie 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.

Numerische und alphanumerische Werte sortieren

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

Doppelte Einträge in zwei Spalten finden

(Tipp 141) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich zwei Spalten auf doppelte Einträge (Zahlen) untersuchen und auf eine 3. Spalte kopieren?

Das Makro durchläuft die Zeilen von lngEZ bis lngLZ in Spalte intS. Immer wenn es in den restlichen Zeilen bis lngLZ eine gleiche Eintragung wie in der aktuellen Zelle findet, prüft es, ob auch die Eintragungen in den anderen beiden Spalten identisch sind. Wenn ja, trägt es in der Spalte intSZ in der aktuellen Zeile ein: "Mehrfach vorhanden." und in den anderen identischen Zeilen die einzelnen Werte der Zellen.

Letzter Wert einer Spalte

(Tipp 143) Nachricht zum Beitrag an Autor Nach oben

Wie bekomme ich den letzten Wert einer Spalte z. B. von B210 nach z. B. A1, wenn die Spalte jeden Tag um einen Wert erweitert wird?

Mit Cells(Rows.Count, 2).End(xlUp).Row bekommt man die Zeile der letzten ausgefüllten Zelle in Spalte 2 (B). Das setzen wir in Cells(Zeile, Spalte) ein, um den Inhalt dieser Zelle zu erhalten und den in A1 einzutragen:

Sub finden() Range("A1") = Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2) End Sub

Spalte versetzen

(Tipp 144) Nachricht zum Beitrag an Autor Nach oben

Wie kann man den Inhalt der aktiven Zelle in der gleichen Zeile in die nächste freie Zelle versetzen?

Wir stellen die letzte ausgefüllte Zelle in der Zeile der aktiven Zelle fest und fügen den Inhalt der aktiven Zelle mit Offset dort ein:

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

Variablen Bereich markieren

(Tipp 145) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich die nächste leere Spalte nach rechts in der Höhe einer Datenbank markieren?

Hier gibt es viele Möglichkeiten.

Der folgende Code stellt die Zeile der letzten ausgefüllten Zelle in Spalte A (1) und die Spalte der letzten ausgefüllten Zelle in Zeile 1 fest. Anschließend wird genau eine Spalte in der Höhe dieser Daten markiert:

Dim lngZ As LongPtr, lngS As LongPtr lngZ = Cells(Rows.Count, 1).End(xlUp).Row lngS = Cells(1, Columns.Count).End(xlToLeft).Column Range(Cells(1, lngS + 1), Cells(lngZ, lngS + 1)).Select

Auch UsedRange kann ggf. gut eingesetzt werden. Hier wird neben dem UsedRange ein Bereich markiert, der genau so breit ist wie der UsedRange:

Dim lngS As LongPtr lngS = ActiveSheet.UsedRange.Columns.Count Range(ActiveSheet.UsedRange.Address).Offset(0, lngS).Select

Die Frage ist natürlich, warum markiert werden soll. Man kann die Elemente auch direkt ansprechen, dann zappelt auch der Bildschirm nicht so.



Kopieren ohne Format übernehmen

(Tipp 146) Nachricht zum Beitrag an Autor Nach oben

Ich möchte aus der Datei_1/Tabelle_1 die Inhalte der Spalten A,B,C in die Datei_2/Tabelle_2 kopieren. Die Datei_2/Tabelle_2 ist aber in Bezug auf Spaltenbreite,Farbe,Rahmen,... bereits formatiert. Diese Formatierung soll erhalten bleiben. Wie ist das auf eine einfache Art möglich?

Workbooks("Datei_1.xlsx").Sheets("Tabelle_1").Range("A:C").Copy Workbooks("Datei_2.xlsx").Sheets("Tabelle_2").Range("P1").PasteSpecial xlValues

Nicht geschützte Zellen suchen

(Tipp 147) Nachricht zum Beitrag an Autor Nach oben

Ich habe die Arbeitsblätter geschützt. Teilweise sind die Zellen aber ungeschützt. Ich würde gerne einfach die Tabelle markieren und dann im VBA die Werte aller ungeschützten Zellen löschen ohne genaue Bezüge angeben zu müssen.

Die gesamte Tabelle nach ungeschützten Zellen durchsuchen zu lassen würde sicher zu lange dauern. Besser ist es, den Bereich, der durchsucht werden soll, einzugrenzen und dann in einer verschachtelten Schleife alle Inhalte ungeschützter Zellen zu löschen. Das Makro wäre dann:

Sub UngeschuetztLoeschen() Dim lngZ As Long, lngZ1 As Long, lngZ2 As Long, lngS As Long, lngS1 As Long, lngS2 As Long lngZ1 = 1 'Erste Zeile mit zu löschenden Inhalten lngZ2 = 100 'Letzte Zeile mit zu löschenden Inhalten lngS1 = 1 'Erste Spalte mit zu löschenden Inhalten lngS2 = 5 'Letzte Spalte mit zu löschenden Inhalten For lngZ = lngZ1 To lngZ2 For lngS = lngS1 To lngS2 Application.StatusBar = Cells(lngZ, lngS).Address If Cells(lngZ, lngS).Locked = False Then Cells(lngZ, lngS).ClearContents Next Next Application.StatusBar = False End Sub

Oder einfach per UsedRange:

Dim rngZelle As Range For Each rngZelle In ActiveSheet.UsedRange If rngZelle.Locked = False Then rngZelle.ClearContents Next

Zellinhalt als Blattname

(Tipp 149) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich das Blatt nach dem Inhalt der Zelle A5 benennen?

Ggf. sollte noch geprüft werden, ob der Blattname schon vergeben ist. Das Übernehmen geht einfach:

Sub Name_anpassen() ActiveSheet.Name = Range("a5").Value End Sub

Zeilen mit 1 löschen

(Tipp 150) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich die Zeile löschen, wenn sich in Spalte A eine 1 befindet?

Die Schleife sucht so lange nach Zellen, die jeweils eine 1 enthalten, bis keine mehr gefunden wird:

Sub Loeschen() Dim rngGef As Range Do Set rngGef = Columns(1).Find(What:="1", LookAt:=xlWhole) If Not rngGef Is Nothing Then Rows(rngGef.Row).Delete Loop While Not rngGef Is Nothing End Sub

Schrift in Kombinationsfeld

(Tipp 151) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich Schriftart, -größe usw eines Kombinationsfeldes aus der Steuerelement-Toolbox ändern?

Das Kombinationsfeld im Entwurfsmodus mit rechts anklicken und Eigenschaften auswählen. Im daraufhin erscheinenden Eigenschaftenfenster findet man die Eigenschaft Font. Hier können die Änderungen vorgenommen werden.

Eigenschaften eines Steuerelements

Blattnamen durch Klick auf Kombinationsfeld einfügen

(Tipp 152) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich auf einem Blatt ein Kombinationsfeld erstellen, in dem die Namen der Blätter enthalten sind? Durch Klick in das Kombinationsfeld soll der angeklickte Name in A1 erscheinen.

  • Menüband Entwicklertools einblenden (Rechtsklick in leere Stelle des Menübands und Menüband anpassen)
  • Einfügen ▸ ActiveX-Steuerelemente ▸ Kombinationsfeld
  • Kombinationsfeld zeichnen
  • Doppelklick auf das Feld, dadurch wird der VBA-Editor geöffnet
  • folgenden Code eingeben (Zelle anpassen):

Private Sub ComboBox1_Change() Range("A1") = ComboBox1.Text End Sub

  • Menü Einfügen - Modul
  • folgendes Makro eingeben (dient zum Füllen des Kombinationsfeldes):

Sub Fuellen() Dim intI As Integer Sheets("Tabelle1").ComboBox1.Clear For intI = 1 To Sheets.Count Sheets("Tabelle1").ComboBox1.AddItem (Sheets(intI).Name) Next End Sub

Durch den Aufruf des Makros Fuellen wird das Kombinationsfeld gefüllt; nach der Auswahl eines Blattes erscheint dessen Name im Beispiel in A1.

Wert aus B1 in erste leere Zelle eines anderen Blattes

(Tipp 154) Nachricht zum Beitrag an Autor Nach oben

Der Wert einer Eingabezelle B1 auf Sheet 1 soll per Makro in eine wachsende Liste auf Sheet 2 kopiert werden. Hierzu soll die erste freie Zelle in Spalte D gesucht werden und dort der Wert eingesetzt werden. Wie kann ich in diesem Kopiervorgang die variable Adressierung festlegen?

Im VBA-Editor doppelt auf das Tabellenblatt klicken, in dem die Eingaben erfolgen. Dann den Code so vervollständigen:

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngZ As LongPtr If Target.Address <> "$B$1" Then Exit Sub lngZ = Sheets(2).Cells(Rows.Count, 4).End(xlUp).Row Sheets(2).Cells(lngZ + 1, 4) = Range("b1") End Sub

Es wird zunächst geprüft, ob die Eingabezelle wirklich B1 ist.

Anschließend wird die Zeile der letzten ausgefüllten Zelle auf Blatt 2 in Spalte 4 (D) festgestellt. Dort wird die Eingabe in die nächste Zeile (lngZ + 1) eingetragen.



Zellbearbeitung aktivieren

(Tipp 155) Nachricht zum Beitrag an Autor Nach oben

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.

10 Zufallszahlen generieren

(Tipp 156) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich untereinander 10 Zufallszahlen generieren, ohne daß Wiederholungen auftreten?

Im ersten Beispiel werden nur die Zahlen in Spalte B erzeugt:

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


Array und Sortieren

In diesem Beispiel mag die einfache Variante kein Problem sein. Aber oft stößt man bei Schleifen, die Zellen lesen und schreiben, auf das Problem, dass die Laufzeit enorm steigt. Deshalb sollte in Betracht gezogen werden, das Ganze mit Arrays zu erledigen.

Die zweite Variante erstellt die Zahlen zunächst nur im Array arrZahlen(). Vom Prinzip her erfolgt dort das Gleiche wie bei der ersten Variante: Es wird so lange geprüft, ob eine neue Zufallszahl bereits vorhanden ist, bis das nicht mehr der Fall ist. Dann bleibt sie eingetragen und es geht zur nächsten Zahl.

Weiterhin ist hier eine Do-Schleife, die die Zahlen nach dem Erstellen aufsteigend sortiert. Auch das erfolgt noch im Array. Wenn keine Sortierung gewollt ist, kann dieser Do-Block auch einfach gelöscht werden.

Erst am Ende werden die Zahlen in die Spalte A geschrieben.

Der Code:

Sub Zufall1() Dim intAnzahl As Integer, intMax As Integer, intMin As Integer Dim intWert As Integer, intI As Integer, intN As Integer Dim bolVorhanden As Boolean, bolSortiert As Boolean Dim arrZahlen() intAnzahl = 10 intMax = 49 intMin = 1 ReDim Preserve arrZahlen(1 To intAnzahl) For intN = 1 To intAnzahl arrZahlen(intN) = Int((intMax * Rnd) + intMin) If intN > 1 Then 'auf Doppelung prüfen und ggf. neue Zahl Do bolVorhanden = False For intI = 1 To intN - 1 If arrZahlen(intI) = arrZahlen(intN) Then bolVorhanden = True arrZahlen(intN) = Int((intMax * Rnd) + intMin) Exit For End If Next Loop While bolVorhanden = True End If Next Do 'Der Schleifenblock kann entfallen, wenn keine Sortierung gewünscht. bolSortiert = True For intN = 1 To intAnzahl - 1 If arrZahlen(intN + 1) < arrZahlen(intN) Then bolSortiert = False intI = arrZahlen(intN + 1) arrZahlen(intN + 1) = arrZahlen(intN) arrZahlen(intN) = intI End If Next Loop While bolSortiert = False Range("A1:A" & intAnzahl).ClearContents For intN = 1 To intAnzahl Cells(intN, 1) = arrZahlen(intN) Next End Sub

Farbnummern anzeigen

(Tipp 158) Nachricht zum Beitrag an Autor Nach oben

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:

Wert kopieren - variabler Zielbereich

(Tipp 390) Nachricht zum Beitrag an Autor Nach oben

Der Wert aus A1 soll in den Bereich kopiert werden, der in C1 enthalten ist.

In C1 steht A3:B10, also soll der Wert aus A1 in die Zellen im Bereich A3:B10 kopiert werden.

Beispiel 1:

Range(Range("C1")) = Range("A1")

Beispiel 2:

Range("A1").Copy Range(Range("C1")).PasteSpecial Paste:=xlPasteValues

Arbeit mit Kombinationsfeld in der Tabelle

(Tipp 403) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich ein Kombinationsfeld füllen und den gewählten Wert an eine Zelle übergeben?

Es geht um das ActiveX-Kombinationsfeld auf einem Tabellenblatt:

  1. In den Entwurfsmodus schalten
  2. mit rechts auf das Kombinationsfeld klicken
  3. Eigenschaften auswählen
  4. bei ListFillRange den Bereich eintragen, z. B. F5:F10
  5. Doppelklick auf die Box
  6. Im Modul den folgenden Code einfügen, den danach anpassen, speichern und den Editor schließen.

Private Sub ComboBox1_Change() Range("A1") = ComboBox1.Text End Sub

Löschen verhindern

(Tipp 412) Nachricht zum Beitrag an Autor Nach oben

Wie kann ich ohne Blattschutz das Löschen verhindern?

Möglichkeit mit Application.Undo:

Wichtig ist, den Bereich festzulegen, in dem das Löschen verhindert werden soll und um welche Daten es sich handelt, die nicht gelöscht werden sollen. Im Beispiel geht es um die Spalte 7 (G), in der sich Formeln befinden.

Dazu eignet sich Worksheet_Change, was Änderungen auf der Tabelle überwacht. Wenn dort in Spalte 7 etwas gelöscht oder durch eine konstanten Wert überschrieben wurde, soll rückgängig gemacht werden:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 7 And Target.HasFormula = False Then Application.Undo End Sub

Anklickbare Landkarte mit Informationen zur Stelle

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

Wie kann ich durch Klick auf eine Stelle einer Landkarte Meldungen anzeigen lassen?



Per VBA Sudoku-Rätsel mit 81 Feldern erstellen

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

Wie kann man per VBA auf einem Tabellenblatt ein Sudoku-Rätsel erstellen?

Hier ist ein Ansatzpunkt, der sicher noch zu verbessern geht:

Eine Datei dazu finden Sie in den Beispieldateien (sudoku.zip)

Hochkomma entfernen

(Tipp 556) Nachricht zum Beitrag an Autor Nach oben

In einem größeren Bereich befinden sich vor den Zahlen Hochkommas, so dass mit den Zahlen nicht gerechnet werden kann. Wie kann man die Hochkommas entfernen?

Range("IV10000") ist eine beliebige Hilfszelle.