Habe unteren Code Dankender weise von Josef Ehrensberger bekommen.
Ich möchte aber wenn ich in den Sheets Jänner bis Dezember in die Zellen A3A154 Doppelklicke,das mir der Wert automatisch in die InputBox eingefügt wird.
Könnte mir dazu bitte jemand helfen?
**********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Sub Suche_Namen()
Dim iIndex%, strSuch_Name$
Dim vntSheets As Variant
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
vntSheets = Array("Jänner", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", _
"September", "Oktober", "November", "Dezember")
strSuch_Name = InputBox("Geben Sie den Namen ein den Sie suchen möchten", "Name Suchen")
If StrPtr(strSuch_Name) = 0 Then GoTo ErrExit
With Worksheets("MA")
For iIndex = 0 To UBound(vntSheets)
.Rows(iIndex * 4 + 3).ClearContents
Find_And_Copy Worksheets(vntSheets(iIndex)).Columns(1), strSuch_Name, .Cells(iIndex * 4 + _
3, 1)
Next
End With
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'Suche_Namen'" & vbLf & String(60, "_") & vbLf & _
vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
_
vbMsgBoxSetForeground, "VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
End Sub
Sub Find_And_Copy(rngBereich As Range, strSuch_Name$, Destination As Range)
Dim rngCell As Range
Set rngCell = rngBereich.Find(What:=strSuch_Name, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rngCell Is Nothing Then rngCell.EntireRow.Copy Destination
Set rngCell = Nothing
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A3:A154")) Is Nothing Then
Cancel = True
Sheets("MA").Activate
End If
Call Suche_Namen
End Sub
GrußHeinz