Vba 从Outlook中的宏保存、打开和排序Excel附件

我每15分钟通过outlook接收一次报告。这些报告实际上以Excel附件的形式提供。我每天只工作8小时；第二天，我通常会有一大堆报告，从前一天开始每隔15分钟就有一次。然后，我必须逐个打开每个报告，然后按标题对其进行排序

我知道如何打开和保存每个未读电子邮件附件，并将其保存到我的计算机上：

         Sub GetAttachments()
             On Error GoTo GetAttachments_err
             Dim ns As NameSpace
             Dim Inbox As MAPIFolder
             Dim SubFolder As MAPIFolder
             Dim Item As Object
             Dim Atmt As Attachment
             Dim FileName As String
             Dim i As Integer

             Set ns = GetNamespace("MAPI")
             Set Inbox = ns.GetDefaultFolder(olFolderInbox)
             Set Mailbox = Inbox.Parent
             Set SubFolder = Mailbox.Folders("Local Archive")
             i = 0

             'check if there is any mail in the folder'
              If SubFolder.Items.Count = 0 Then
              MsgBox "There are no messages in the folder.", vbInformation, _
                 "Nothing Found"
               Exit Sub
               End If

          'Check each message and save the attachment'
            If SubFolder.Items.Count > 0 Then
              For Each Item In SubFolder.Items
                 If Item.UnRead = True Then
                     For Each Atmt In Item.Attachments
                      FileName = "C:\Users\badana\Desktop\" & Atmt.FileName
                      Atmt.SaveAsFile FileName 'saves each attachment'

                      'this code opens each attachment'
                       Set myShell = CreateObject("WScript.Shell")
                       myShell.Run FileName

                       'this sets the email as read'
                        Item.UnRead = False
                       'updates the counter'
                       i = i + 1

                        Next Atmt
                  End If
              Next Item
            End If

  'Display results

  If i > 0 Then
   MsgBox "I found " & i & " attached files." _
   & vbCrLf & "They are saved on your desktop" _
   & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
   Else
 MsgBox "I didn't find any attached files in your mail.", vbInformation, _
 "Finished!"
 End If

       'Replenish Memory'
        GetAttachments_exit:

       Set Atmt = Nothing
       Set Item = Nothing
       Set ns = Nothing
        Exit Sub

 'function for sorting the excel attachment'


  GetAttachments_err:
  MsgBox "An unexpected error has occurred." _
  & vbCrLf & "Please note and report the following information." _
  & vbCrLf & "Macro Name: GetAttachments" _
  & vbCrLf & "Error Number: " & Err.Number _
  & vbCrLf & "Error Description: " & Err.Description _
  , vbCritical, "Error!"
    Resume GetAttachments_exit
 End Sub

我有按标题对每个附件进行排序的代码：

Sub SortData()
'
' SortData Macro
' sorts data
'

'
  Dim lngLast As Long
  lngLast = Range("A" & Rows.Count).End(xlUp).Row

  Cells.Select
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Add Key:=Range("A2:A" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Add Key:=Range("K2:K" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("02APR14").Sort
    .SetRange Range("A1:L" & lngLast)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
 End Sub

---

但是，我希望能够在outlook中组合这两个代码，这样我就可以从outlook将其作为一个宏运行，它将打开和保存每个附件，并一次性对它们进行排序。这可能吗

我使用了您的排序数据宏，并对其进行了一些编辑，以便在给定文件名时打开一个文件

您需要使用刚刚保存的附件的文件名，从outlook宏中调用此函数。例如，从保存代码中删除以下行：

Set myShell = CreateObject("WScript.Shell")
myShell.Run FileName

并替换为：

openAndSort(FileName) 

可以在outlook vba的同一模块中添加以下代码。它使用早期绑定，因此您需要添加对excel对象库的引用（工具->引用->microsoft excel 14对象库）

Sub openAndSort(filename As String)
'
'
'
'
Dim lngLast As Long

Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Set xl = New Excel.Application
Set wb = xl.Workbooks.Open(filename)
Set sh = wb.Worksheets("02APR14")
xl.Visible = True
  lngLast = sh.Range("A" & Rows.Count).End(xlUp).Row

sh.Sort.SortFields.Clear
sh.Sort.SortFields.Add Key:=sh.Range("A2:A" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
sh.Sort.SortFields.Add Key:=sh.Range("K2:K" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
    .SetRange sh.Range("A1:L" & lngLast)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

wb.Save
wb.Close
Set wb = Nothing
xl.Quit
Set xl = Nothing
End Sub