Hier eine Neufassung des mdlDirectory, das auch Namen beginnend mit CH oder SCH (nur der optischen Symmetrie wegen) filtert. S oder C liefern zwar auch CH und SCH, aber die Shapes CH und SCH ermöglichen den direkten Filter.
Code: Alles auswählen
Option Explicit
Sub Setup()
ActiveSheet.Cells.Clear
MakeDir32
MakeTestData
End Sub
Private Sub MakeDir32()
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", "CH", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "---", "P", "Q", "R", "S", "SCH", "T", "U", "V", "W", "X", "Y", "Z", "Ä", "Ö", "Ü", "123", "*")
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 17
.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 17
.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
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
Private Sub MakeTestData()
Dim i As Integer, r As Integer, c As Integer
Dim aChrs
aChrs = Array("A", "B", "C", "CH", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "SCH", "T", "U", "V", "W", "X", "Y", "Z", "Ä", "Ö", "Ü", "123")
r = 9
Application.ScreenUpdating = False
For i = 0 To UBound(aChrs)
For c = 1 To 20
Cells(r, 1) = aChrs(i)
r = r + 1
Next c
Next i
Columns(1).NumberFormat = "@"
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 9 To r
Cells.EntireRow(i).Hidden = True
Next i
Application.ScreenUpdating = True
End Sub
Private Sub ClickOnShape()
Dim i As Integer, r As Integer, iLen As Integer, sName As String, sValue As String, vChar
Application.ScreenUpdating = False
With ActiveSheet
Cells.EntireRow.Hidden = False
r = .Cells(Rows.Count, 1).End(xlUp).Row
sName = .Shapes(Application.Caller).Name
iLen = Len(sName) - 5
vChar = Right(sName, Len(sName) - 5)
End With
For i = 9 To r
Cells.EntireRow(i).Hidden = True
Next i
'MsgBox vChar, , iLen & " <-> " & r
If vChar = "*" Then
Cells.EntireRow.Hidden = False
Exit Sub
ElseIf vChar = "---" Then
For i = 9 To r
Cells.EntireRow(i).Hidden = True
Next i
Exit Sub
Else
For i = 9 To r
sValue = Left(Cells(i, 1), iLen)
Cells.EntireRow(i).Hidden = True
If sValue = vChar Then
Cells.EntireRow(i).Hidden = False
End If
If IsNumeric(sValue) = True And IsNumeric(vChar) = True Then
Cells.EntireRow(i).Hidden = False
End If
Next i
End If
Application.ScreenUpdating = True
End Sub
zu verzichten...
