Jörg Lorenz: Excel, VBA-Beispiele

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

Hinweise zu den Beispielen finden Sie hier: Beispiele

Kategorie: Beispiel > Excel > VBA > Suche

Textzahl zu Zahl

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 65)

Manchmal stehen Zahlen nach dem Import aus anderen Programmen links in der Zelle und werden auch nicht als Zahl interpretiert. Wie kann man das ändern?

Hier ist ein Beispiel, das den Excel-internen Befehl Inhalte einfügen - Multiplikation verwendet. Nehmen wir an, in A1 steht die Ziffer 1. Dann kann man die Textzahlen umwandeln mit:

Range("A1").Copy
Range("B1:B21").PasteSpecial Operation:=xlMultiply, SkipBlanks:=True

Sternchen (*) löschen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 66)

Wie kann ich "*" löschen?

Vor das Sternchen setzt man einfach eine Tilde ~.

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

Zeilenumbrüche aus Excel-Zellen entfernen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 67)

In Excel-Zellen kann ein manueller Zeilenumbruch mit ALT + Eingabetaste erreicht werden. Das führt u. a. beim Import von Excel-Tabellen in Access oder cvs-Dateien zu erheblichen Problemen. Wie kann man diese ALT-Eingabetaste aus großen Tabellen entfernen, ohne alle Zellen anwählen zu müssen?

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

Aktuelles Datum suchen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 68)

Ich habe eine Datei mit verschiedenen Blättern. Blatt 1 ist Januar, Blatt 2 Februar usw. Nun möchte ich wenn ich die Datei starte, daß automatisch das aktuelle Datum aktiviert wird. Ich meine damit, der Cursor sollte genau beim Tagesdatum stehen (natürlich sollte auch das entsprechende Blatt aktiv sein).

Sub suchen()
Dim rngSuchbegriff As Range
Sheets(Format(Date, "MMMM")).Select
Set rngSuchbegriff = Cells.Find(What:=Date, LookAt:=xlWhole, LookIn:=xlValues)
If rngSuchbegriff Is Nothing = False Then Range(rngSuchbegriff.Address).Activate
End Sub

Umlaute ersetzen lassen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 69)

Wie kann ich im Bereich A5 bis C10 alle Umlaute in Selbstlaute umwandeln und umgekehrt?

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

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

Doppelte Unterstriche durch einen ersetzen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 70)

Für jede Zelle einer Spalte soll überprüft werden, ob mehrere Unterstriche hintereinander vorkommen. Diese sollen eliminiert und auf einen Unterstrich begrenzt werden.

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

Sonderzeichen durch Unterstriche ersetzen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 71)

In verschiedenen Zellen einer Spalte sollen die Sonderzeichen durch Unterstriche ersetzt werden.

Sub Raus_damit()
Dim strInhalt As String, lngZ1 As Long, lngZn As Long, lngZ As Long
Dim intS As Integer, intI As Integer, intZ As Integer
intS = 1        'Spalte A
lngZ1 = 1       'Erste Zeile
lngZn = 25      'Letzte Zeile
For lngZ = lngZ1 To lngZn
    strInhalt = Cells(lngZ, intS)
    For intI = 1 To Len(strInhalt)
        intZ = Asc(Mid(strInhalt, intI, 1))
        If intZ >= 123 And intZ <= 255 Then Mid(strInhalt, intI, 1) = "_"
    Next
    Cells(lngZ, intS) = strInhalt
Next
End Sub

Tabellenblatt durchsuchen und bestätigen lassen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 72)

Wie kann man ein Tabellenblatt nach einem vorgegebenen Begriff absuchen und bei jeder gefundenen Zelle bis zur Bestätigung verharren?

Sub Auswahl()
Dim rngZelle As Range, strBegriff As String
strBegriff = InputBox("Bitte Suchbegriff eingeben:", Application.UserName)
If strBegriff = "" Then Exit Sub
Set rngZelle = ActiveSheet.Columns("A:F").Find(strBegriff)
If rngZelle Is Nothing Then
    Beep
    MsgBox "Suchbegriff nicht gefunden!", , Application.UserName
    Exit Sub
End If
rngZelle.Select
MsgBox rngZelle.Address(False, False)
rngZelle.Offset(1).Select
While ActiveCell.Address <> rngZelle.Address
    Cells.FindNext(After:=ActiveCell).Activate
    If ActiveCell.Address = rngZelle.Address Then Exit Sub
    MsgBox ActiveCell.Address(False, False)
Wend
End Sub

Geburtstagskinder des heutigen Tages in Userform anzeigen:

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 376)

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?

Sub Geburtstag()
Dim lngZ0 As Long, lngZ As Long
Dim objBlatt As Object

lngZ0 = 3                                           'Erste Zeile mit Nachnamen

For Each objBlatt In ActiveWorkbook.Sheets          'Auf jedem Blatt suchen
    'Soll nur auf den beiden Blättern gesucht werden, Hochkomma entfernen.
    'If objBlatt.Name = "Dienstlich" Or objBlatt.Name = "Privat" Then
        lngZ = lngZ0
        
        Application.ScreenUpdating = False          'Bildschirmaktualisierung ausschalten
        With objBlatt
            Do While .Cells(lngZ, 5).Value <> ""     'Solange auf dem Blatt suchen, wie in Spalte 5 was steht
                Application.StatusBar = "Überprüft wird: " & .Cells(lngZ, 5).Value
                If IsDate(.Cells(lngZ, 6).Value) Then
                    If Day(.Cells(lngZ, 6).Value) = Day(Date) And Month(.Cells(lngZ, 6).Value) = Month(Date) Then
                        UserForm1.ListBox1.AddItem (.Cells(lngZ, 3).Value & " " & .Cells(lngZ, 4).Value & " " & .Cells(lngZ, 5).Value & " wird heute " & Year(Date) - Year(.Cells(lngZ, 6).Value) & ", Telefon: " & .Cells(lngZ, 10).Value & " (Blatt: " & objBlatt.Name & ")")
                        UserForm1.ListBox1.AddItem ("-------------------------")
                    End If
                End If
                lngZ = lngZ + 1
            Loop
        End With
    'End If                                         'Soll nur auf den beiden Blättern gesucht werden, Hochkomma entfernen.
Next                                                'Nächstes Blatt
Application.ScreenUpdating = True                   'Bildschirmaktualisierung einschalten
Application.StatusBar = False                       'Statusleiste zurücksetzen
UserForm1.Caption = "Heutige Geburtstage - exklusiv für " & Application.UserName
UserForm1.Show
End Sub

Excel, Scripte, Alltagslösungen

Jörg Lorenz

Datenschutzerklärung