das suchte jemand ein Möglichkeit, seine Adresstabelle jeweils nach dem ersten Buchstaben zu filtern. Mit der Eingabe M möchte er gerne alle Müller, Meier, Mayer, Meir und Motzers ... sehen, aber alle andere nicht.
Angeboten wurden ihm zielführende Formel-Lösungen. Ich biete hier eine VBA-Lösung an: Man nehme eine beliebige Tabelle mit Kunden, Socken oder Hobbies und ergänze in ein Allg. Modul diesen Code:
Code: Alles auswählen
Option Explicit
Private Sub ClickOnShape()
Dim i As Integer, r As Integer, sName As String
sName = ""
With ActiveSheet
Cells.EntireRow.Hidden = False
r = .Cells(Rows.Count, 1).End(xlUp).Row
sName = .Shapes(Application.Caller).Name
End With
For i = 9 To r
Cells.EntireRow(i).Hidden = True
Next i
'MsgBox sName, , r
If Right(sName, 1) = "*" Then
Cells.EntireRow.Hidden = False
Exit Sub
Else
For i = 9 To r
Cells.EntireRow(i).Hidden = True
If Left(Cells(i, 1), 1) = Right(sName, 1) Then
Cells.EntireRow(i).Hidden = False
End If
Next i
End If
End Sub
Private Sub ShowTime(sgDelay As Single)
Dim sgShow As Single
sgShow = Timer + sgDelay 'sgDelay = 0.05 = 0,05 Sekunden
Do While Timer < sgShow
DoEvents
Loop
End Sub
Sub MakeDir29()
Dim shp As Shape
Dim i As Integer, a As Integer, c As Integer, r As Integer, iOffset As Integer 'dynamische Parameter
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer 'fixe Parameter
Dim aChrs
aChrs = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "Ä", "Ö", "Ü", "*")
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 4) = "Dir_" Then
shp.Delete
End If
Next
iLeft = 50: iTop = 25: iWidth = 50: iHeight = 25 'wo soll das erste Segment wie hoch und breit denn hin?
iOffset = iLeft
i = 0
With ActiveSheet
For c = 1 To 15
.Shapes.AddShape(msoShapeRectangle, iOffset, iTop, iWidth, iHeight).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(200, 200, 255)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange
.Name = "Dir_ " & aChrs(i)
.TextFrame.Characters.Text = aChrs(i)
End With
i = i + 1
iOffset = iOffset + iWidth * 1.05 'hier lässt sich der horizontale Abstand zwischen Shapes feinjustieren
ShowTime 0.01
Next c
iLeft = 50: iTop = 54: iOffset = iLeft 'hier lässt sich der vertikale Abstand zwischen Zeile 1 & 2 feinjustieren
For c = 1 To 15
.Shapes.AddShape(msoShapeRectangle, iOffset, iTop, iWidth, iHeight).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(200, 200, 255)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange
.Name = "Dir_ " & aChrs(i)
.TextFrame.Characters.Text = aChrs(i)
End With
i = i + 1
iOffset = iOffset + iWidth * 1.05
ShowTime 0.01
Next c
For Each shp In ActiveSheet.Shapes 'hier bekommen ALLE Shapes ihr Fett weg: 1.) Textformatierung
shp.Select
With Selection.ShapeRange
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.TextFrame.Characters.Font.Bold = True
.TextFrame.Characters.Font.Size = 16
.TextFrame.HorizontalAlignment = xlCenter
.TextFrame.VerticalAlignment = xlCenter
End With
shp.OnAction = "ClickOnShape" 'hier bekommen ALLE Shapes ihr Fett weg: 2.) ihr Universal-Makro verpasst
Next
.Cells(1, 1).Select
End With
End Sub
Dann führe man das Makro MakeDir29 (Alt-F8) aus und teste. Jeder als Shape dargestellte Buchstabe setzt einen Filter. Das "'*" zeigt wieder alle Einträge.
Lässt sich auf die verschiedensten Listen anwenden und anpassen.
Viel Spaß damit!
lg
Nachtrag: Step-by-step für VBAnfänger:
Zuerst oberhalb der Daten acht Leerzeilen einfügen: Rechte Maustaste in Zeile 1: Zellen einfügen x 8.
Dann mit Alt+F11 den VB-Editor öffnen.
Im linken oberen Fenster (Projekt-Explorer) mit der rechten Maustaste > Einfügen > Modul das allg. Modul bauen
Den gesamten Code von hier kopieren und in das neue Modul (großes Fenster rechts) einfügen (gibt es die Zeile Option Expl... zweimal, eine davon löschen)
Zurück zur Tabelle, dort mit Alt+F8 das Makro-Menü aufrufen und MakeDir29 ausführen.
Zeitaufwand: keine zwei Minuten
Den Editor schließen und testen ....
