Initialien in Tabelle einfügen

[Ralf Brinkmann]

Hallo zusammen!

Ich habe eine *.xls Arbeitsmappe (Excel 2013) mit mehreren Blättern für
verschiedene Jahre.

Ich möchte nun gerne, dass immer dann, wenn ich auf einem Blatt in
Spalte A einen neuen Eintrag vornehme, automatisch in Spalte 14 die
Initialien des Anwenders eingetragen werden. Mit VBA.

Also irgendwas in der Art

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("A:A")) Is Nothing Then Exit
Sub

With Target
If Cells(.Row, 1).Value = "" Then
Cells(.Row, 14).Value =
CreateObject("Word.Application").UserInitials
End If
End With
End Sub

(so ähnlich funktioniert es in einer ganz anderen Tabelle).

Ich will das aber nicht für jedes einzelne Blatt jedes Jahr neu einfügen
müssen, sondern gleich eine Formel für alle Jahre in "Diese
Arbeitsmappe". Kann mir da jemand bei helfen?

Gruß, Ralf

[Claus Busch]

Hallo Ralf,

Post by Ralf Brinkmann
Ich möchte nun gerne, dass immer dann, wenn ich auf einem Blatt in
Spalte A einen neuen Eintrag vornehme, automatisch in Spalte 14 die
Initialien des Anwenders eingetragen werden. Mit VBA.

probiere es mal so:

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("A:A")) Is Nothing _
Or Target.Count > 1 Then Exit Sub

Dim varUN As Variant
Dim myStr As String

If Len(Target) > 0 Then
varUN = Split(Application.UserName, " ")
myStr = Left(varUN(0), 1) & Left(varUN(1), 1)
Target.Offset(, 13) = myStr
End If

End Sub


Mit freundlichen Grüßen
Claus

[Ralf Brinkmann]

Hallo Claus!

Post by Ralf Brinkmann
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("A:A")) Is Nothing _
Or Target.Count > 1 Then Exit Sub
Dim varUN As Variant
Dim myStr As String
If Len(Target) > 0 Then
varUN = Split(Application.UserName, " ")
myStr = Left(varUN(0), 1) & Left(varUN(1), 1)
Target.Offset(, 13) = myStr
End If
End Sub

Leider funktioniert das nur, wenn ich es in den Formelbereich eines
Arbeitsblattes eintrage, nicht für die ganze Arbeitsmappe. Ich müsste
das also Jahr für Jahr wiederholen. Besser gesagt die anderen Anwender.

Außerdem fügt es den "Usernamen" ein, in diesem Fall "RB", nicht mein
"Bri", das ich in den Einstellungen in Word eingetragen habe. Deshalb
dachte ich ja an dieses

CreateObject("Word.Application").UserInitials

das in einer anderen Exceltabelle bestens funktioniert (allerdings auch
wieder nur in einem Blatt).

Kannst Du das vielleicht noch irgendwie umpfriemeln? Ich bin wirklich
nicht gut darin.

Gruß, Ralf

[Claus Busch]

Hallo Ralf,

Post by Ralf Brinkmann
Leider funktioniert das nur, wenn ich es in den Formelbereich eines
Arbeitsblattes eintrage, nicht für die ganze Arbeitsmappe. Ich müsste
das also Jahr für Jahr wiederholen. Besser gesagt die anderen Anwender.
Außerdem fügt es den "Usernamen" ein, in diesem Fall "RB", nicht mein
"Bri", das ich in den Einstellungen in Word eingetragen habe. Deshalb
dachte ich ja an dieses

dann füge folgenden Code in das Modul "DieseArbeitsmappe" ein:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Or _
Target.Count > 1 Then Exit Sub

Dim myStr As String
Dim objWord As Object

Set objWord = CreateObject("Word.Application")

If Len(Target) > 0 Then
myStr = objWord.UserInitials
Target.Offset(, 13) = myStr
End If
End Sub


Mit freundlichen Grüßen
Claus

[Ralf Brinkmann]

Hallo Claus!

Post by Claus Busch
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Or _
Target.Count > 1 Then Exit Sub
Dim myStr As String
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
If Len(Target) > 0 Then
myStr = objWord.UserInitials
Target.Offset(, 13) = myStr
End If
End Sub

Wunderbar. Das war wieder einmal ein schönes Weihnachtsgeschenk von Dir.

Weißt Du übrigens, warum da so eine lange Verzögerung eintritt, bevor
die Initialien hinten sichtbar werden?

Gruß, Ralf

[Claus Busch]

Hallo Ralf,

Post by Ralf Brinkmann
Weißt Du übrigens, warum da so eine lange Verzögerung eintritt, bevor
die Initialien hinten sichtbar werden?

es muss ja zuerst einmal Word gestartet werden, um UserInitials nutzen
zu können.
Mit em UserName aus Excel ginge es schneller.


Mit freundlichen Grüßen
Claus

[Claus Busch]

Hallo Ralf,

Post by Ralf Brinkmann
Weißt Du übrigens, warum da so eine lange Verzögerung eintritt, bevor
die Initialien hinten sichtbar werden?

damit nicht bei jedem Eintrag Word gestartet werden muss, könnte Word
beim Öffnen der Datei gestartet werden und die User Initialen in eine
öffentlichen Variablen gespeichert werden. Die hält solange wie die
Mappe geöffnet ist.
Also im Modul "DieseArbeitsmappe":

Private Sub Workbook_Open()
Kürzel
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
If Intersect(Target, Range("A:A")) Is Nothing Or _
Target.Count > 1 Then Exit Sub

If Len(Target) > 0 Then Target.Offset(, 13) = myStr

End Sub

Und in einem Standardmodul:

Public myStr As String
Sub Kürzel()
Dim objWord As Object

Set objWord = CreateObject("Word.Application")
myStr = objWord.userinitials
End Sub


Mit freundlichen Grüßen
Claus

[Ulrich Möller]

Post by Claus Busch
Hallo Ralf,

Post by Ralf Brinkmann
Weißt Du übrigens, warum da so eine lange Verzögerung eintritt, bevor
die Initialien hinten sichtbar werden?

damit nicht bei jedem Eintrag Word gestartet werden muss, könnte Word
beim Öffnen der Datei gestartet werden und die User Initialen in eine
öffentlichen Variablen gespeichert werden. Die hält solange wie die
Mappe geöffnet ist.
Private Sub Workbook_Open()
Kürzel
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Or _
Target.Count > 1 Then Exit Sub
If Len(Target) > 0 Then Target.Offset(, 13) = myStr
End Sub
Public myStr As String
Sub Kürzel()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
myStr = objWord.userinitials
End Sub
Mit freundlichen Grüßen
Claus

alternativ auch über die Registry:

Public Function GetUserInitials() As Variant
Dim objWsh As Object

Set objWsh = CreateObject("WScript.Shell")
GetUserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End Function

zumindest bei Office 2010

Ulrich

[Ralf Brinkmann]

Hallo Ulrich!

Post by Ulrich Möller
Public Function GetUserInitials() As Variant
Dim objWsh As Object
Set objWsh = CreateObject("WScript.Shell")
GetUserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End Function
zumindest bei Office 2010

Echt? Das ist ja interessant. Muss ich mal ausprobieren. Ich weiß
allerdings nicht, ob das dann auch bei unseren Dienstrechnern geht.

Ansonsten funktiniert die (zweite) Lösung von Claus Busch wie gewohnt
sehr gut.

Gruß, Ralf

[Ralf Brinkmann]

Hallo Ulrich!

Post by Ulrich Möller
Public Function GetUserInitials() As Variant
Dim objWsh As Object
Set objWsh = CreateObject("WScript.Shell")
GetUserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End Function
zumindest bei Office 2010

Gerade getestet. Bei meinem Excel 2013 geht es auch. Es ist nicht
schneller als die Lösung von Claus, aber es funktioniert.

Gruß, Ralf

[Ulrich Möller]

Hallo Ralf,

Post by Ralf Brinkmann

Post by Ulrich Möller
Public Function GetUserInitials() As Variant
Dim objWsh As Object
Set objWsh = CreateObject("WScript.Shell")
GetUserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End Function
zumindest bei Office 2010

Echt? Das ist ja interessant. Muss ich mal ausprobieren. Ich weiß
allerdings nicht, ob das dann auch bei unseren Dienstrechnern geht.
Ansonsten funktiniert die (zweite) Lösung von Claus Busch wie gewohnt
sehr gut.

Man muß schauen, wo genau in der Registry das steht, denn das scheint
von Version zu Version etwas unterschiedlich zu sein. Solange vom
Administrator der Zugriff auf das Scripting Object nicht explizit
unterbunden ist, sollte es funktionieren, da der User immer Zugriff auf
seinen Zweig HKCU hat.

Es geht in erster Linie darum, nicht erst eine neue Instanz Word starten
zu müssen, sollte also etwas flotter sein und damit weniger
"Seiteneffekte" haben.
Natürlich kann man auch, wie Claus bereits beschrieben hat, beim
Programmstart einmalig das über Word machen und dann zwischenspeichern.
Allerdings würde ich das dann etwas anders gestalten, z.B. nach dem
Muster, wenn die Globale Variable leer ist, Word starten und auslesen
und ansonsten einfach den Inhalt der Variablen zurückgeben, denn
globale Variablen können nach einem Fehler oder im Debug.Modus ihren
Inhalt verlieren. Dient nur der Stabilität bzw. Fehlervermeidung. Den
selben Trick kann man natürlich auch mit dem Zugriff über die Registry
anwenden. So muß nicht immer das Scripting Object neu geladen werden.

Ulrich


Ulrich

[Ulrich Möller]

Hier die modifizierte Version mit "Caching":

Public Function GetUserInitials() As Variant
Static UserInitials As Variant
Dim objWsh As Object

If Format$(UserInitials) = vbNullString Then
Set objWsh = CreateObject("WScript.Shell")
UserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End If

GetUserInitials = UserInitials
End Function

Ulrich

[Ralf Brinkmann]

Hallo Ulrich!

Post by Ulrich Möller
Public Function GetUserInitials() As Variant
Static UserInitials As Variant
Dim objWsh As Object
If Format$(UserInitials) = vbNullString Then
Set objWsh = CreateObject("WScript.Shell")
UserInitials =
objWsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\\Common\Userinfo\UserInitials")
Set objWsh = Nothing
End If
GetUserInitials = UserInitials
End Function

Danke!

Gruß, Ralf