Office: (Office 2010) Zellen aus Tabellenblättern per Makro für bestimmte Nutzer ohne PW-Abfrage freigeben

Hallo zusammen,

da ich ein absoluter Neuling im VBA-Editor in Excel bin, möchte ich hier um Hilfe bitten.

Mein Problem besteht darin, dass ich einzelne Zellen in Tabellenblättern nur für bestimmte andere Benutzer zugänglich machen will.
Dabei soll der Benutzername unter Windows abgefragt werden. Wenn dieser stimmt, soll das Passwort umgangen werden und der Zugriff auf die Zelle gewährleistet werden.
Mit der Schaltfläche "Benutzer dürfen Bereiche bearbeiten" habe ich es schon versucht, jedoch ohne Erfolg, da Excel sofort abschmiert, wenn ich die Personen eintrage, die Zugriff erhalten sollen.

Bezogen auf meine Datei:

B23 und C27 in Tabellenblatt Dienstreiseantrag für Person A
H29 in Tabellenblatt Dienstreiseabrechnung für Person A, B, C
P29 in Tabellenblatt Dienstreiseabrechnung für Person D, E

Ich freue mich auf eure Antworten.

Freundliche Grüße

Betalo

 

Hallo,

Um den Usernamen zu ermitteln, kannst Du die in VBA integrierte Funktion Environ verwenden oder dies per Windows API ermitteln (falls Environ z.B. nicht geht). Anbei ein Beispiel:

Code:

Option Explicit


Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long


Public Function GetUserNameByAPI()


  Dim strBuffer As String * 255
  Dim lngSize   As Long
  Dim lngResult As Long
  
  lngSize = 255
  lngResult = GetUserName(strBuffer, lngSize)
  
  If lngResult <> 0 Then
  
    GetUserNameByAPI = Left(strBuffer, lngSize - 1)
    
  End If
  
End Function


Public Function GetUserNameByEnvironment()


  GetUserNameByEnvironment = Environ("Username")
  
End Function


Sub Test()


  MsgBox "'" & GetUserNameByEnvironment & "'"
  MsgBox "'" & GetUserNameByAPI & "'"
  
End Sub

Das Ergebnis kannst Du dann nutzen, um per If oder Select Case die User auszuwählen.

Gruß

 

Hallo maninweb,

danke für deine Hilfe, aber du hast mich wohl missverstanden. Die Benutzernamen der Windows-Anmeldung der Mitarbeiter sind mir bekannt. Mir geht es darum, dass die oben genannten Zellen nur für diese Leute änderbar sein sollen und niemand anderes darauf zugreifen darf.

Gruß

Betalo

 

Code:

If lngResult = "Chef" Then
            ActiveSheet.Unprotect ("123")
            Range("B23").Locked = False
            Range("B23").Select
    End If

Beim Schließen Blattschutz wieder rein und fertig.

 

Hallo Lutz Fricke,

wenn ich deinen Code eingebe und für meine Tabelle anpasse, kriege ich immer die Fehlermeldung Variable nicht definiert. Was muss ich ändern?

Code:
Sub Unterschrift()

If lngResult = "sf000145" Then
ActiveSheet.Unprotect ("sf000145")
Range("B23", "C27").Locked = False
Range("B23", "C27").Select
End If

End Sub

 

Hallo Betalo,

Du hast verschiedene Möglichkeiten:
Wenn Du's einfach machen willst, löscht Du die erste Zeile deines Moduls "Option Explicit" raus und fertig.
Wenn Du's gescheit machen willst, fügst Du nach "Sub Unterschrift" in die nächste Zeile "Dim lngResult As Long" ein. Damit definierst Du deine Variable.

Eine Frage: Dein Passwort ist identisch mit Deinem Blattnamen?

Gruß,
Lutz

 

Ich hab den Code so verstanden, dass nach lngResult der Benutzername hinkommt, also vorerst sf000145 um zu schauen ob's funktioniert, wenn ja kommt da ein anderer rein und das Passwort ist sf000145 was nach active.sheet.unprotect steht.
Oder kommt danach der Blattname rein?

Vielen Dank für deine Hilfe.

Gruß

Betalo

 

Dann hast Du's richtig verstanden.

Gruß,
Lutz

 

Gut zu wissen.
Jetzt bleibt mir nur noch eine Frage: Muss ich deinen Code unter den anderen schreiben? Weil da funktioniert es bei mir nicht.
und wenn ich lngresult als Long deklariere kommt immer der fehler "Typen unverträglich" was ich soweit auch nachvollziehen kann, da der Benutzername auch aus Buchstaben besteht. Ich hatte es jetzt mit string probiert, trotzdem tut sich da nichts.

Gruß

Betalo

 

Hast Du mal deinen gesamten Code?

 

Option Explicit


Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long


Public Function GetUserNameByAPI()



Dim strBuffer As String * 255
Dim lngSize As Long
Dim lngResult As Long

lngSize = 255
lngResult = GetUserName(strBuffer, lngSize)

If lngResult <> 0 Then

GetUserNameByAPI = Left(strBuffer, lngSize - 1)

End If

End Function


Public Function GetUserNameByEnvironment()


GetUserNameByEnvironment = Environ("Username")

End Function


Sub Test()

MsgBox "'" & GetUserNameByEnvironment & "'"
MsgBox "'" & GetUserNameByAPI & "'"

End Sub

Sub Unterschrift()


Dim lngResult As String

If lngResult = "sf000145" Then
ActiveSheet.Unprotect ("sf000145")
Range("B23", "A27").Locked = False
Range("B23", "A27").Select
End If

End Sub

 

Hallo Betalo,

ok, ich seh schon, Du bist wirklich blank, was VBA angeht. Hast Du schon mal VBA programmiert oder nur aufgezeichnet und abgespielt?

Leg Dir eine neue Mappe (Kopie der bestehenden) an, lösch alles aus dem Modul, in dem du die Makros stehen hast, und kopieren diesen Code hinein:

Code:

Option Explicit


Public Function GetUserNameByEnvironment()

GetUserNameByEnvironment = Environ("Username")

End Function


Sub Unterschrift()

If GetUserNameByEnvironment = "sf000145" Then
ActiveSheet.Unprotect ("sf000145")
Range("B23", "A27").Locked = False
Range("B23", "A27").Select
End If

End Sub 

Dann solltest Du nur noch ein Makro (Unterschrift) aufrufen können. Was passiert dann?

Bin jetzt erstmal ins Wochenende und weiß noch nicht genau, ob ich dir helfen kann. Ansonsten geht's Montag weiter.

Gruß,
Lutz

 

Hallo Lutz Fricke,

ich arbeite heute das erste Mal mit VBA, bisher brauchte ich es auch noch nicht. Von daher vielen Dank für deine Geduld und Ausdauer. Du hast mir sehr geholfen.

Mir wird nur noch das Makro Unterschrift aufgeführt und es funktioniert einwandfrei.

Viel Spaß dir in deinem wohlverdienten Wochenende.

Gruß

Betalo