Вытащите файлы из вложений электронной почты и скопируйте первый лист из всех них в текущую книгу

Question

Я получаю много писем с прикрепленными файлами Excel.Они находятся в подпапке в моем Outlook.Теперь я хочу вытащить только вложения из Outlook и вставить их в папку на рабочем столе.На втором шаге первый лист всех этих книг должен быть вставлен в текущую книгу, где я могу визуализировать данные.

Пока оба шага работают, но только для одного файла.После этого код останавливается.Но я хочу, чтобы все вложенные файлы в подпапке моего Outlook были скопированы и вставлены в папку на моем рабочем столе, а первая рабочая таблица всех рабочих книг в той же папке была скопирована и вставлена ​​в мою текущую рабочую книгу.Основанием для этого является то, что я хочу визуализировать данные, которые я получаю по электронной почте от моих коллег.Поэтому это те шаги, которые я, хотя и был разумным.Если бы была возможность только скопировать и вставить соответствующий диапазон из рабочих книг в папку на моем рабочем столе, это было бы еще лучше, поскольку это заняло бы один шаг.

Заранее спасибо за помощь!

Sub PullAttachmentFromOutlook()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
'        If you use "" it will create a date/time stamped folder for you in 
your "Documents" folder
'        Note: If you use this "C:\Users\Ron\test" the folder must exist.

  SaveEmailAttachmentsToFolder "NameofOutlookSubfolder", "xlsm", 
  "C:\Users\..."

 End Sub


Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                             ExtString As String, DestFolder As String)
  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 MyDocPath As String
  Dim I As Integer
  Dim wsh As Object
  Dim fs As Object

  On Error GoTo ThisMacro_err

  Set ns = GetNamespace("MAPI")
  Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

  I = 0
  ' Check subfolder for messages and exit if none found
  If SubFolder.Items.Count = 0 Then
      MsgBox "No Messages in this folder: " & OutlookFolderInInbox, _
           vbInformation, "Nothing Found"
      Set SubFolder = Nothing
      Set Inbox = Nothing
      Set ns = Nothing
      Exit Sub
  End If

  'Create DestFolder if DestFolder = ""
  If DestFolder = "" Then
      Set wsh = CreateObject("WScript.Shell")
      Set fs = CreateObject("Scripting.FileSystemObject")
      MyDocPath = wsh.SpecialFolders.Item("mydocuments")
      DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
      If Not fs.FolderExists(DestFolder) Then
        fs.CreateFolder DestFolder
     End If
  End If

  If Right(DestFolder, 1) <> "\" Then
    DestFolder = DestFolder & "\"
  End If

  ' Check each message for attachments and extensions
  For Each Item In SubFolder.Items
      For Each Atmt In Item.Attachments
          If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) 
Then
              FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
              Atmt.SaveAsFile FileName
              I = I + 1
          End If
      Next Atmt
  Next Item

   ' Show this message when Finished
  If I > 0 Then
      MsgBox "Die Dateien sind hier zu finden : " _
           & DestFolder, vbInformation, "Finished!"
  Else
      MsgBox "No Data attached to email.", vbInformation, "Finished!"
  End If

  ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

     ' Error information
ThisMacro_err:
     MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

'Второй шаг:

Option Explicit

Sub CopySheetFromFileOnDesktop()

Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim MyPath As String
Dim MyFile As String
Dim SheetIndex As Integer



Application.ScreenUpdating = False

Set wkbDest = ThisWorkbook
Set wksDest = wkbDest.Worksheets("Tabelle1")

SheetIndex = 1

MyPath = "C:\Users\..."

If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

MyFile = Dir(MyPath & "*.xlsm")

Do While Len(MyFile) > 0
    Set wkbSource = Workbooks.Open(MyPath & MyFile)
    Set wksSource = wkbSource.Worksheets("Time & Expense Reporting")
    wksSource.Copy Before:=wkbDest.Sheets(SheetIndex)
    wkbSource.Close savechanges:=False
    MyFile = Dir
Loop

Application.ScreenUpdating = True

MsgBox "Completed...", vbInformation


End Sub

Как объяснено выше.Код только копирует и вставляет одно вложение электронной почты моей подпапки Outlook.И то же самое на втором шаге, где первый лист из папки на моем рабочем столе должен быть скопирован и вставлен в текущую книгу.Как сделать так, чтобы он копировал и вставлял все вложения в подпапку Outlook, а затем копировал и вставлял первый лист каждого файла в папку на моем рабочем столе.В идеале они должны быть переименованы после вставки (например, Sheet1 (1); Sheet1 (2)) Или Excel делает это автоматически, когда листы с одинаковым именем вставляются в одну и ту же книгу?

Любая помощь по этому вопросу будет очень признателен!