Nun aber doch noch (weil sonst wohl...
28.09.2007 03:37:44
Luc:-?
...niemand mehr antwortet), Wolfgang.
Mein Bsp entspricht zwar nur ungefähr dem deinen, aber meine Lösung würde auch bei dir fktionieren. Ich habe eine Textergänzungseingabe in Zelle A1 vorgesehen. Das kann aber auch eine beliebige andere sein; du musst das Pgm dann nur entsprechend ändern (alles, was geändert wdn darf, steht am PgmAnfang!).
Natürlich wäre stattdessen auch eine analoge Eingabe per InputBox oder sogar strukturierter per UserForm möglich, aber so geht's ja auch...
1. Ausgangssituation:
2. Eingabe der Textergänzung für die ausgewählte Zelle:
3. Automatischer Eintrag in die Ausgangszelle und Rücksprung:
Und hier noch die Subprozedur, die in ein normales Modul des Projektes zu speichern ist ( _
Einfügen - Modul). Dabei bitte den Hinweis in der 1.Pgmzeile beachten!
Sub TxtErg(Optional ByRef Ziel, Optional ByVal Eing) 'Achtung! Verweis auf `MS VBA _
Extensibility 5.3´ muss gesetzt sein!
Rem Proc pgmd & pbld by LuCyWorXxl in MMVIIsep27-28 on www.herber.de
Const eb As String = "EBer", ez As String = "__", tz As String = ";"
Static rziel As Range
Dim ec(3) As Boolean, ebs As Variant, ebt() As Variant, xw As Variant, zf As Variant, _
i As Integer, p As Integer, xz As Range, cp As VBComponent, ws As Worksheet
On Error Resume Next
zf = Array(15, 2): ebs = Array(47, 3)
ebt = Array("Korrektur-maskenfeld", "Mit Trenn-""" & tz & """ eingeben!")
Set xz = ActiveSheet.Cells(1, 1)
If IsMissing(Ziel) Then
Set xz = Nothing
If MsgBox("Ereignisprozeduren werden installiert!", _
vbExclamation + vbOKCancel, "EventProxInstall") = vbCancel Then Exit Sub
Set ws = ActiveWorkbook.ActiveSheet: i = -1
With ActiveWorkbook.VBProject
For Each cp In .VBComponents
If cp.Type = vbext_ct_Document Then i = i + 1
If i = ws.Index Then
With cp.CodeModule
If IsError(.ProcCountLines("Worksheet_Change", vbext_pk_Proc)) Then _
.CreateEventProc "Change", "Worksheet": ec(0) = True
While .Lines(.ProcStartLine("Worksheet_Change", _
vbext_pk_Proc) + p, 1) "End Sub": p = p + 1: Wend
If Not ec(0) Then
If InStr(.Lines(.ProcStartLine("Worksheet_Change", vbext_pk_Proc), _
p), "TxtErg") = 0 Then _
.InsertLines .ProcStartLine("Worksheet_Change", vbext_pk_Proc) + _
p, _
" Rem --- Lines inserted by CyWorX.TxtErg on " & Date & " _
---" & vbLf & _
" Rem --- Relocate following lines & activate by _
removing leading ""'""! ---" & vbLf & _
"' With Target" & vbLf & "' If .Cells.Count = 1 _
And .Column + .Row = 2 Then" & _
vbLf & "' If .Value """" Then Run ""TxtErg"", _
Target" & vbLf & _
"' End If" & vbLf & "' End With": ec(2) = True
Else: .ReplaceLine .ProcStartLine("Worksheet_Change", vbext_pk_Proc) + _
p - 1, _
" Rem --- Procedure generated by CyWorX.TxtErg on " & Date & _
" ---" & vbLf & _
" With Target" & vbLf & " If .Cells.Count = 1 And . _
Column + .Row = 2 Then" & _
vbLf & " If .Value """" Then Run ""TxtErg"", _
Target" & vbLf & _
" End If" & vbLf & " End With" & vbLf & " Set _
Target = Nothing": ec(2) = True
End If
p = 0
If IsError(.ProcCountLines("Worksheet_SelectionChange", vbext_pk_Proc)) _
Then _
.CreateEventProc "SelectionChange", "Worksheet": ec(1) = True
While .Lines(.ProcStartLine("Worksheet_SelectionChange", _
vbext_pk_Proc) + p, 1) "End Sub": p = p + 1: Wend
If Not ec(1) Then
If InStr(.Lines(.ProcStartLine("Worksheet_SelectionChange", _
vbext_pk_Proc), p), "TxtErg") = 0 _
Then .InsertLines .ProcStartLine("Worksheet_SelectionChange", _
vbext_pk_Proc) + p, _
" Rem --- Lines inserted by CyWorX.TxtErg on " & Date & " _
---" & vbLf & _
" Rem --- Relocate following lines & activate by _
removing leading ""'""! ---" & vbLf & _
"' With Target" & vbLf & "' If .Cells.Count = 1 _
And .Column = 1 And " & _
".Row > 2 Then Run ""TxtErg"", Target, True" & vbLf & "' _
End With": ec(3) = True
Else: .ReplaceLine .ProcStartLine("Worksheet_SelectionChange", _
vbext_pk_Proc) + p - 1, _
" Rem --- Procedure generated by CyWorX.TxtErg on " & Date & _
" ---" & vbLf & _
" With Target" & vbLf & " If .Cells.Count = 1 And . _
Column = 1 And " & _
".Row > 2 Then Run ""TxtErg"", Target, True" & vbLf & " End _
With" & vbLf & _
" Set Target = Nothing": ec(3) = True
End If
End With
Exit For
End If
Next cp
End With
Application.MacroOptions Macro:="TxtErg", Description:="Durch Zellauswahl angesteuerte _
Textergänzungseingabe (für " & _
ez & ") mit Trennzeichen " & tz & " für mehrere Ergänzungen _
pro Zellentext. Installation " & _
"der zugehörigen Ereignisprozeduren mittels (einmaligem) _
Direktaufruf."
MsgBox "Ereignisprozedur Wsh_Change " & IIf(ec(2), IIf(ec(0), "installiert!", "ergänzt!" _
), "existiert!") & vbLf & _
"Ereignisprozedur Wsh_SelectionChange " & IIf(ec(3), IIf(ec(1), "installiert", " _
ergänzt"), "existiert") & "!", _
IIf(ec(2) And ec(3), vbInformation, IIf(ec(2) Or ec(3), vbQuestion, _
vbExclamation)) + vbOKOnly, _
"EventProx in " & cp.Name
Set cp = Nothing: Set ws = Nothing: Exit Sub
End If
If Not TypeName(Ziel) = "Range" Then MsgBox "Kein gültiges Ziel!", vbCritical + vbOKOnly, " _
Error Abort": Exit Sub
If IsMissing(Eing) Then
Eing = False
ElseIf IsNumeric(Eing) Then
Eing = CBool(Eing)
Else: MsgBox "Kein gültiger Modus!", vbCritical + vbOKOnly, "Error Abort": Exit Sub
End If
i = Abs(Eing)
Application.EnableEvents = False
With Ziel
If Not rziel Is Nothing Or InStr(.Value, ez) > 0 Then
If Eing And InStr(.Value, ez) = 0 Then i = 1 - i
With ActiveSheet.Shapes(eb).TextFrame.Characters
.Text = ebt(i): .Font.ColorIndex = ebs(i): .Font.Bold = CBool(i - 1)
End With
xz.Interior.ColorIndex = zf(i)
End If
If Not Eing Then
For Each xw In Split(.Value, tz)
p = InStr(rziel, ez)
rziel = Replace(rziel, ez, Trim(xw), 1, 1)
While Mid(rziel, p + Len(Trim(xw)), 1) = Left(ez, 1)
rziel = Replace(rziel, Left(ez, 1), "", 1, 1)
Wend
Next xw
.Value = "": rziel.Select: Set rziel = Nothing
ElseIf InStr(.Value, ez) > 0 Then
Set rziel = Ziel: xz.Activate
End If
End With
Set xz = Nothing
Application.EnableEvents = True
End Sub
Das Pgm wird im Makro-Manager angezeigt und muss beim 1.Mal auch dort gestartet wdn. Es generiert dann die für die Automatisierung erforderlichen Ereignisprozeduren im Klassenmodul des gerade ausgewählten TabBlattes der aktuellen ArbMappe. Das sollte dann natürlich das sein, in dem du diese Fktionalität benötigst! Gleichzeitig wird eine Beschreibung der Prozedur erzeugt, die leider nur im Objektmanager des VBA-Editors in voller Länge angezeigt wird. Im Makromanager wird der Text abgeschnitten, enthält aber noch die für die normale Verwendung notwendigen Infos.
Übrigens solltest du sicherheitshalber noch die von der Forumssoftware automatisch gesetzten Zeilentrenner _ so entfernen, dass die Zeile normal fortgesetzt wird. Allerdings habe ich auch einige Trenner gesetzt. Die automatisch gesetzten erkennst du daran, dass der ihnen nachfolgende PgmText direkt am linken Rand beginnt (Ausnahme: 1., 3.[2.] und letzte Zeile).
Gruß Luc :-?
PS für alle Interessierten: Das Ganze ist auch ein inzwischen typisches Bsp meiner Herangehensweise an den Einsatz von Ereignisprozeduren... ;-)