Inserare UserName si adresa de email

zvonacfirst
Mesaje: 85
Membru din: Mie Feb 19, 2014 10:41 pm

Inserare UserName si adresa de email

Mesaj de zvonacfirst » Dum Oct 29, 2017 11:08 pm

Buna.
Am urmatorul cod atasat unui CommandButton.
Codul as vrea sa aduca:
- in coloana A incepand cu A11 --> Application.UserName (celulele A1:A10 sunt ocupate)
- in coloana B incepand cu B11 --> adresa de email a userului (celulele B1:B10 sunt ocupate)
Codul nu trebuie sa multiplice informatiile, adica daca un user si o adresa de email exista in lista, codul nu trebuie sa le mai scrie odata.
Codul nu functioneaza si nu ii dau de cap. Rog ajutor.
Multumesc

Cod: Selectaţi tot

   Dim OL, olAllUsers, oExchUser, oentry, myitem As Object
   Dim User As String
   Dim EmptyRow

If Me.OptionButton1 = Unchecked _
And Me.OptionButton2 = Unchecked Then
MsgBox "Nicio optiune exprimata." & vbCrLf & "Alegeti Da sau Nu.", vbOKOnly, "Informatie necesara"
End If

If Me.OptionButton2.Value = True Then
Application.DisplayAlerts = False
ThisWorkbook.Close SaveChanges:=False

ElseIf Me.OptionButton1.Value = True Then
    Worksheets("Revizuire").Activate
    ActiveSheet.Unprotect ""
    
    Set OL = CreateObject("outlook.application")
    Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries
    User = OL.Session.CurrentUser.Name
    Set oentry = olAllUsers.Item(User)
    Set oExchUser = oentry.GetExchangeUser()
    
    For Each Cell In Range("A11:A1000")
        If Cell.Value = Application.UserName Then
        Exit Sub
    Else
        EmptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
        Cells(EmptyRow, 1).Select
        Selection.Value = Application.UserName
        End If
    Next Cell
    
    For Each Cell In Range("B11:B1000")
        If Cell.Value = oExchUser.PrimarySmtpAddress Then
        Exit Sub
    Else
        EmptyRow = WorksheetFunction.CountA(Range("B:B")) + 1
        Cells(EmptyRow, 1).Select
        Selection.Value = oExchUser.PrimarySmtpAddress
    End If
    Next Cell
        
    ActiveSheet.Protect ""
    ThisWorkbook.Save
    ThisWorkbook.Close
End If

End Sub

Scrie răspuns

Înapoi la “Visual Basic for Application (VBA) cu Excel - Intrebari tehnice”