我每天晚上 8 点都会收到三封电子邮件，每封电子邮件都包含一个 Excel/csv 附件。我想从每个附件中提取数据，获取一个范围并将该数据粘贴到外部本地保存的主 Excel 工作表中的三个范围中。
我还需要输入详细信息：
AttachmentTitles(1) = "Queue Status - Collections.csv"
AttachmentTitles(2) = "KPI Collections - Inbound.csv"
AttachmentTitles(3) = "KPI Collections - Outbound.csv"
' Copy the data from the Excel attachment
"Queue Status - Collections.csv" - Range = "A2:S12"
"KPI Collections - Inbound.csv" - Range = "H2:X12"
"KPI Collections - Outbound.csv" - Range = "H2:X12"
' Set the range where you want to paste the extracted data
"Queue Status - Collections.csv" - Range = "A2:S12" data should always paste into the next available Row in "Collections Master Workbook.xlsx"
"KPI Collections - Inbound.csv" - Range = "H2:X12" data should always paste into the 20th column of the same available Row as previous
"KPI Collections - Outbound.csv" - Range = "H2:X12" data should always paste into the 37th column of the same available Row as previous
' Specify the Outlook folder where the email is located
Inbox.Projects.Collections.Daily Reports - It's a sub-sub-subfolder if that makes sense?
最终应将 11 行 53 列数据粘贴到“Collections Master Workbook.xlsx”中。
Sub ExtractDataFromOutlookEmail()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim OutlookFolder As Object
Dim OutlookItem As Object
Dim ExcelApp As Object
Dim ExcelWorkbook As Object
Dim ExcelWorksheet As Object
Dim Attachment As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim RangeToExtract As Range
' Set the path where you want to save the extracted data
TempFilePath = Environ$("temp") & ""
' Set the range where you want to paste the extracted data
Set RangeToExtract = ThisWorkbook.Sheets("Sheet1").Range("A1") ' Change to your desired range
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
' Specify the Outlook folder where the email is located
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' Change to the appropriate folder
' Loop through the emails in the folder
For Each OutlookItem In OutlookFolder.Items
' Check if the email has the desired attachments
If OutlookItem.Attachments.Count >= 1 Then
' Check if the attachments have specific titles
Dim AttachmentTitles(1 To 3) As String
AttachmentTitles(1) = "Attachment1.xlsx" ' Replace with the title of the first attachment
AttachmentTitles(2) = "Attachment2.xlsx" ' Replace with the title of the second attachment
AttachmentTitles(3) = "Attachment3.xlsx" ' Replace with the title of the third attachment
Dim AttachmentCount As Integer
AttachmentCount = 0
' Loop through the attachments in the email
For Each Attachment In OutlookItem.Attachments
For i = 1 To 3
If Attachment.Filename = AttachmentTitles(i) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(i)
' Create a new Excel application
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
' Open the saved Excel attachment
Set ExcelWorkbook = ExcelApp.Workbooks.Open(TempFilePath & AttachmentTitles(i))
' Copy the data from the Excel attachment
Set ExcelWorksheet = ExcelWorkbook.Sheets(1) ' Assuming data is in the first sheet
ExcelWorksheet.UsedRange.Copy Destination:=RangeToExtract.Offset(, AttachmentCount * 3) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
ExcelApp.Quit
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
Set ExcelApp = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next i
Next Attachment
' Exit the loop after processing the email
Exit For
End If
Next OutlookItem
' Clean up Outlook objects
Set OutlookItem = Nothing
Set OutlookFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
' Delete the temporary Excel files
For i = 1 To 3
If Dir(TempFilePath & AttachmentTitles(i)) <> "" Then
Kill TempFilePath & AttachmentTitles(i)
End If
Next i
End Sub
我尝试了多种组合。
第一个错误是编译错误：
用户定义类型未定义
它突出显示
Dim RangeToExtract As Range“Collections Master Workbook.xlsx”中的代码。
ExcelAppOption Explicit
Sub ExtractDataFromOutlookEmail()
' Late binding. Outlook variables declared as Object.
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim OutlookFolder As Object
Dim OutlookItem As Object
Dim Attachment As Object
Dim ExcelWorkbook As Workbook
Dim ExcelWorksheet As Worksheet
Dim TempFilePath As String
Dim RangeToExtract As Range
' Set the path where you want to save the extracted data
TempFilePath = Environ$("temp")
' Set the range where you want to paste the extracted data
' **** ThisWorkbook is used - code must be in Excel ****
Set RangeToExtract = ThisWorkbook.Sheets("Sheet1").Range("A1") ' Change to your desired range
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Specify the Outlook folder where the email is located
'Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' Change to the appropriate folder
' With late binding
' https://learn.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6) ' Change to the appropriate folder
'Set OutlookFolder = OutlookNamespace.pickfolder
'Application.ScreenUpdating = False
' Loop through the emails in the folder
For Each OutlookItem In OutlookFolder.Items
'Debug.Print OutlookItem.Subject
If TypeName(OutlookItem) = "MailItem" Then
' Check if the email has the desired attachments
If OutlookItem.Attachments.Count >= 1 Then
' Check if the attachments have specific titles
Dim AttachmentTitles(1 To 3) As String
AttachmentTitles(1) = "Attachment1.xlsx" ' Replace with the title of the first attachment
AttachmentTitles(2) = "Attachment2.xlsx" ' Replace with the title of the second attachment
AttachmentTitles(3) = "Attachment3.xlsx" ' Replace with the title of the third attachment
Dim AttachmentCount As Long
AttachmentCount = 0
' Loop through the attachments in the email
Dim i As Long
For Each Attachment In OutlookItem.Attachments
For i = 1 To 3
If Attachment.Filename = AttachmentTitles(i) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(i)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(i))
' Copy the data from the Excel attachment
Set ExcelWorksheet = ExcelWorkbook.Sheets(1) ' Assuming data is in the first sheet
ExcelWorksheet.UsedRange.Copy Destination:=RangeToExtract.Offset(, AttachmentCount * 3) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next i
Next Attachment
End If
End If
Next OutlookItem
' Clean up Outlook objects
Set OutlookItem = Nothing
Set OutlookFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
' Delete the temporary Excel files
For i = 1 To 3
If Dir(TempFilePath & AttachmentTitles(i)) <> "" Then
Kill TempFilePath & AttachmentTitles(i)
End If
Next i
Application.ScreenUpdating = True
End Sub
如果您想要 Outlook 中的代码，
ExcelAppOutlookApp打开“Collections Master Workbook.xlsx”。替换
ThisWorkbook选项显式
子ExtractDataFromOutlookEmail()
' Late binding. Outlook variables declared as Object.
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim OutlookFolder As Object
Dim OutlookItem As Object
Dim Attachment As Object
Dim ExcelWorkbook As Workbook
Dim ExcelWorksheet As Worksheet
Dim TempFilePath As String
Dim RangeToExtract As Range
Dim RangeToCopy As Range
' Set the path where you want to save the extracted data
TempFilePath = Environ$("temp")
' Set the range where you want to paste the extracted data
' **** ThisWorkbook is used - code must be in Excel ****
Set RangeToExtract = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1) ' Change to your desired range
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Specify the Outlook folder where the email is located
'Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' Change to the appropriate folder
' With late binding
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6) ' Change to the appropriate folder
'Set OutlookFolder = OutlookNamespace.pickfolder
'Application.ScreenUpdating = False
' Loop through the emails in the folder
For Each OutlookItem In OutlookFolder.Items
'Debug.Print OutlookItem.Subject
If TypeName(OutlookItem) = "MailItem" Then
' Check if the email has the desired attachments
If OutlookItem.Attachments.Count >= 1 Then
' Check if the attachments have specific titles
Dim AttachmentTitles(1 To 3) As String
AttachmentTitles(1) = "Queue Status - Collections.csv" ' Replace with the title of the first attachment
AttachmentTitles(2) = "KPI Collections - Inbound.csv" ' Replace with the title of the second attachment
AttachmentTitles(3) = "KPI Collections - Outbound.csv" ' Replace with the title of the third attachment
Dim AttachmentCount As Long
AttachmentCount = 0
' Loop through the attachments in the email
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(1) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(1)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(1))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("A2:S12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(2) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(2)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(2))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 19) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(3) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(3)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(3))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 36) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
End If
End If
Next OutlookItem
' Clean up Outlook objects
Set OutlookItem = Nothing
Set OutlookFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
' Delete the temporary Excel files
If Dir(TempFilePath & AttachmentTitles(1)) <> "" Then
Kill TempFilePath & AttachmentTitles(1)
End If
If Dir(TempFilePath & AttachmentTitles(2)) <> "" Then
Kill TempFilePath & AttachmentTitles(2)
End If
If Dir(TempFilePath & AttachmentTitles(3)) <> "" Then
Kill TempFilePath & AttachmentTitles(3)
End If
Application.ScreenUpdating = True
结束子