für claudia
30.03.2004 20:16:43
mischa
claudia,
mit deiner excel-version kannste meinen code mit alt+f11 nich anzeigen - hier isser als text:
Option Explicit
Option Base 0
Private Const MaxSuchZeilen = 21 'So viele Zeilen werden maximal durchsucht
Private Const MaxSuchSpalten = 40 'so viele spalten werden durchsucht
Private Const SuchwertA = 0 'Nach diesem Wert wird standardmäßig gesucht
Private Suchwert As Variant
Private Type GefundeneZellenA
ObenLinksTOP As Long
ObenLinksLEFT As Long
End Type
Private GefundeneZellen() As GefundeneZellenA
Sub ZellenMitWertenFinden()
Suchwert = InputBox("Nach welchem Wert soll gesucht werden?", "Suchwertabfrage", SuchwertA)
If Suchwert = "" Then Exit Sub
'Suchwerte in der Tabelle reinschreiben:
Cells(MaxSuchZeilen + 1, 1).Value = "Gesucht wird nach: " & Suchwert
Cells(MaxSuchZeilen + 2, 1).Value = "Durchsuchte Zeilen: 0 bis " & MaxSuchZeilen
Cells(MaxSuchZeilen + 3, 1).Value = "Durchsuchte Spalten: 0 bis " & MaxSuchSpalten
Dim ZelleA As Object
ReDim GefundeneZellen(0)
Application.ScreenUpdating = False
For Each ZelleA In ActiveSheet.Cells
If ZelleA.Row >= MaxSuchZeilen Then Exit For
If ZelleA.Column
Application.StatusBar = "Zeile: " & ZelleA.Row & " - Spalte: " & ZelleA.Column
If ZelleA.Text = Suchwert And ZelleA.Value "" Then
ZelleA.Interior.ColorIndex = 3
GefundeneZellenSpeichern (ZelleA.Top + ZelleA.Height / 2), (ZelleA.Left + ZelleA.Width / 2)
ZelleA.Font.Bold = True
Else
ZelleA.Interior.ColorIndex = 22
ZelleA.Font.Bold = False
End If
End If
Next
'Dim RetVal As Long
'RetVal = MsgBox("Linien ziehen", vbYesNo)
'If RetVal = vbYes Then Call LinienZiehen
LinienZiehen
Beep
End Sub
Private Sub GefundeneZellenSpeichern(OLiT As Long, OLiL As Long)
ReDim Preserve GefundeneZellen(UBound(GefundeneZellen()) + 1)
GefundeneZellen(UBound(GefundeneZellen())).ObenLinksLEFT = OLiL
GefundeneZellen(UBound(GefundeneZellen())).ObenLinksTOP = OLiT
'Debug.Print Time & ": Eintrag Nr.: " & UBound(GefundeneZellen()) & _
"= LeftWert: " & GefundeneZellen(UBound(GefundeneZellen())).ObenLinksLEFT & _
"; TOP_Wert: " & GefundeneZellen(UBound(GefundeneZellen())).ObenLinksTOP
End Sub
Private Sub LinienZiehen()
'alte Linien löschen:
Dim LInieA As Shape
For Each LInieA In ActiveSheet.Shapes
If LInieA.Top <> 0 And LInieA.Left <> 0 Then
'der links oben und links außen befindliche Button soll mal nicht gelöscht werden!
LInieA.Delete
End If
Next
'Linienziehen
Dim MaxGefundeneZellen As Long
MaxGefundeneZellen = UBound(GefundeneZellen())
If MaxGefundeneZellen < 2 Then
MsgBox "Es wurde keine oder nur eine Zelle gefunden, deshalb werden keine Linien eingefügt!", vbExclamation
Exit Sub
End If
Dim StartOLiT As Long, StartOLiL As Long, EndeOLiT As Long, EndeOLiL As Long
Dim Linienzähler As Long
Dim ZÄhler1 As Long, Zähler2 As Long
For ZÄhler1 = 1 To MaxGefundeneZellen - 1
For Zähler2 = ZÄhler1 + 1 To MaxGefundeneZellen
StartOLiT = GefundeneZellen(ZÄhler1).ObenLinksTOP
StartOLiL = GefundeneZellen(ZÄhler1).ObenLinksLEFT
EndeOLiT = GefundeneZellen(Zähler2).ObenLinksTOP
EndeOLiL = GefundeneZellen(Zähler2).ObenLinksLEFT
With ActiveSheet.Shapes.AddLine(StartOLiL, StartOLiT, EndeOLiL, EndeOLiT).Line
'.DashStyle = msoLineThickBetweenThin
.ForeColor.RGB = RGB(100, 50, 128)
.Weight = 1.5
End With
Linienzähler = Linienzähler + 1
Next Zähler2
Next ZÄhler1
Application.StatusBar = "Insgesamt eingefügte Linien: " & Linienzähler
Range("a1").Activate
End Sub
'MischaRichter
'www.miaj.de