Question

我尝试使用excel vba自动设置项目的方法，但对编码很新。

到目前为止我所拥有的功能是从我的outlooks全局地址列表中获取人名和电子邮件，并将其存储到excel页面（＆＃34;电子邮件地址＆＃34;）它根据项目所需的职位类型做了下一件事，它通过电子邮件地址＆＃34; excel上的页面，在公司内找到该位置的人员，并提供一个供用户选择的下拉列表。最后，在选择名称后，它会为每个团队成员提供电子邮件地址。

以下是我目前的代码。

Sub emailfromoutlook()

Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 3) As String
Dim UserIndex As Long
Dim i As Long

Set appOL = CreateObject("Outlook.Application")
Set oGAL = appOL.GetNamespace("MAPI").AddressLists("Global Address List").AddressEntries


Worksheets("Email Address").Activate

For i = 1 To oGAL.Count
    Set oContact = oGAL.Item(i)
    If oContact.AddressEntryUserType = 0 Then
        Set oUser = oContact.GetExchangeUser
        If Len(oUser.LastName) > 0 Then
            UserIndex = UserIndex + 1
            arrUsers(UserIndex, 1) = oUser.JobTitle
            arrUsers(UserIndex, 2) = oUser.Name
            arrUsers(UserIndex, 3) = oUser.PrimarySmtpAddress

        End If
    End If
Next i

appOL.Quit

If UserIndex > 0 Then
    Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
End If

Set appOL = Nothing
Set oGAL = Nothing
Set oContact = Nothing
Set oUser = Nothing
Erase arrUsers


End Sub

Sub dependent_list()

Dim a As Integer
Dim b As String


Range("C2:C50").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With

a = 2
Do Until Worksheets("Sheet1").Cells(a, 2) = 0


Dim find As String
Dim array1(200)
Dim i As Integer
Dim j As Integer
Dim k As String

Worksheets("Email Address").Select
Erase array1
find = Worksheets("Sheet1").Cells(a, 2).Value
For i = 2 To 330
k = Worksheets("Email Address").Cells(i, 1)
If k = find Then

    array1(j) = Worksheets("Email Address").Cells(i, 2)
j = j + 1
Else
    'do it another thing
End If
Next i

Worksheets("Sheet1").Select
    Cells(a, 3).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(array1, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    a = a + 1
Loop
End Sub

Sub email()

Dim c As Integer
Dim d As String
Dim e As String
Dim f As Integer

For c = 2 To 50
d = Worksheets("Sheet1").Cells(c, 3).Value

For f = 2 To 330
e = Worksheets("Email Address").Cells(f, 2)

If d = e Then
Worksheets("Sheet1").Cells(c, 4) = Worksheets("Email Address").Cells(f, 3)
Else
End If
Next f
Next c


End Sub

这项工作正常，因为它允许我根据项目中的可用位置选择团队成员并向我提供他们的电子邮件地址，但它有一个缺陷。 outlook中的全局地址列表将随着时间的推移而更新（作为人员，雇佣和解雇），但它不会直接更新excel上的电子邮件地址页面。

为了解决这个问题，我写的一个临时解决方案是每次打开时刷新excel页面以防万一，但这不是一个好的长期解决方案。

  Private Sub Workbook_Open()
    Sheets("Email Address").UsedRange.ClearContents
    Call emailfromoutlook
    Worksheets("Email Address").Range("A1") = "Job Title"
    Worksheets("Email Address").Range("B1") = "Full Name"
    Worksheets("Email Address").Range("C1") = "Email Address"
    Worksheets("Email Address").Range("A1:C1").Font.Bold = True
    MsgBox "Email Address book has been updated"
    End Sub

因此，对于长期修复，我正在考虑是否可以将全局地址列表存储在临时数组中，然后执行所有这些功能，而不是将它们放在Excel页面上。但是，我对如何实现这一点没有丝毫的线索。

非常感谢任何帮助或不同的想法。当我意识到这是一个非常漫长而复杂的问题时，请随时要求澄清。

谢谢。

将地址存储到数组中，然后在该临时数组中查找数据

0 个答案: