Excel & VBA

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

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

VBA

Grundsätzlich:

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

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

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

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

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

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

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

oder:

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

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

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

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

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

Formel

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

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

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

Oder:

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

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

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

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

Der Inhalt von A1 wird in die Fußzeile eingetragen:

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

Pfad und Dateiname werden eingetragen:

ActiveSheet.PageSetup.LeftFooter = ActiveWorkbook.path & "\" & ActiveWorkbook.Name

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.

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

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

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

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

VBA

Sub TabellenblattName() MsgBox ActiveSheet.Name End Sub

Formel

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

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

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

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)

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.

Dazu gibt es verschiedene Möglichkeiten.

Direkt in Zellen eintragen

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

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

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

Weiteres Beispiel - Schleife statt Find:

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

Erst Array, zum Schluss in Zellen

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

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

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

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

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

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

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

Dynamische Arrayformel mit Matrixfunktion (ab Excel 365)

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

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

In die Zelle kommt einfach:

=Zufallszahlen_Eindeutig(Anzahl;Minimum;Maximum)

=Zufallszahlen_Eindeutig(5;1;49)

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

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

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

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

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

Variante 1

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

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

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

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

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

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

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

Erweiterte Variante mit benutzerdefinierter Funktion (UDF)

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

In dem Fall versagt die erste Variante.

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

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

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

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

Das ist die Funktion:

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

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

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

Variante mit regulären Ausdrücken/Regular Expressions

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

Das Suchmuster wäre in diesem Fall:

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

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

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

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

Beschleunigen: Sortieren per Array

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

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

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

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

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

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

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

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

Die Routine als Ganzes:

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

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

Beispieldatei

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

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

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

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.

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

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

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

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

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.

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

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.

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:

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

Formeln

="abc " & A1 & "def"

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

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

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

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

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

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

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

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

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

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

VBA

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

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

Excel 365: Funktion TEXTVERKETTEN()

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

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

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

Zum Schluss gibt man irgendwo diese Formel ein:

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

Fertig ist die komplette HTML-Tabelle.

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

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

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 einen 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