从Outlook提取CSV数据至XLSM未自动分列，请求技术解决

核心问题出在附件保存时未添加.csv后缀，导致Excel将其识别为普通文本文件，打开后所有内容挤在一列；同时原代码的粘贴逻辑存在偏移错误。以下是修正后的代码：

Sub ExtractActivitiesData()
    ' Late binding. Outlook variables declared as Object.
    Dim OutlookApp As Object
    Dim ExcelApp As Object
    Dim ThisWorkbook 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 TempCSVPath As String
    
    Dim TargetSheet As Worksheet
    Dim NextRow As Long
    
    ' 设置临时文件路径
    TempFilePath = Environ$("temp")
    TempCSVPath = TempFilePath & "\temp_activities.csv" ' 带.csv后缀的临时文件
    
    ' 初始化Excel应用和目标工作簿
    Set ExcelApp = CreateObject("Excel.Application")
    Set ThisWorkbook = ExcelApp.Workbooks.Open("T:\3-Lending Systems Analyst\Collections Master Workbook.xlsm")
    Set TargetSheet = ThisWorkbook.Sheets("Sheet2") ' 目标工作表
    
    ' 初始化Outlook应用和文件夹
    Set OutlookApp = CreateObject("Outlook.Application") ' 改用CreateObject避免上下文冲突
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6).Folders("Projects").Folders("Collections").Folders("Activities Reports")
    
    ExcelApp.ScreenUpdating = False
    
    ' 遍历邮件
    For Each OutlookItem In OutlookFolder.Items
        If TypeName(OutlookItem) = "MailItem" Then
            ' 遍历附件，仅处理CSV文件
            For Each Attachment In OutlookItem.Attachments
                ' 判断是否为CSV附件
                If LCase(Right(Attachment.FileName, 4)) = ".csv" Then
                    ' 保存CSV附件到临时路径
                    Attachment.SaveAsFile TempCSVPath
                    
                    ' 打开CSV文件，指定分隔符确保列拆分
                    Set ExcelWorkbook = ExcelApp.Workbooks.Open( _
                        Filename:=TempCSVPath, _
                        Format:=6, ' 6代表逗号分隔
                        Delimiter:=Comma _
                    )
                    
                    ' 获取CSV数据范围（从A2开始到最后一行有数据的列）
                    With ExcelWorkbook.Sheets(1)
                        Set RangeToCopy = .Range("A2", .Cells(.Rows.Count, "R").End(xlUp))
                    End With
                    
                    ' 获取目标工作表的下一行空行
                    NextRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row + 1
                    
                    ' 将数据粘贴到目标位置（仅粘贴值，避免格式问题）
                    RangeToCopy.Copy
                    TargetSheet.Cells(NextRow, 1).PasteSpecial Paste:=xlPasteValues
                    
                    ' 关闭临时CSV文件
                    ExcelWorkbook.Close SaveChanges:=False
                    
                    ' 清理对象
                    Set ExcelWorkbook = Nothing
                    
                    ' 只处理第一个CSV附件，跳出循环
                    Exit For
                End If
            Next Attachment
        End If
    Next OutlookItem
    
    ' 清理Outlook对象
    Set OutlookItem = Nothing
    Set OutlookFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    
    ' 删除临时CSV文件
    If Dir(TempCSVPath) <> "" Then Kill TempCSVPath
    
    ' 恢复屏幕更新并保存关闭
    ExcelApp.ScreenUpdating = True
    ThisWorkbook.Save
    ThisWorkbook.Close
    ExcelApp.Quit
    
    ' 清理Excel对象
    Set TargetSheet = Nothing
    Set ThisWorkbook = Nothing
    Set ExcelApp = Nothing
End Sub

关键改动说明： #

• 添加.csv后缀：临时文件命名为temp_activities.csv，确保Excel识别为CSV格式。
• 指定CSV打开参数：使用Workbooks.Open的Format和Delimiter参数，强制按逗号拆分列（如果你的CSV用其他分隔符，比如制表符，可将Delimiter改为vbTab）。
• 优化目标行计算：准确获取目标工作表的下一行空行，实现增量添加。
• 仅粘贴值：避免原CSV的格式干扰目标工作簿，确保数据正确写入。
• 过滤CSV附件：只处理后缀为.csv的附件，避免错误处理其他类型文件。

内容的提问来源于stack exchange，提问作者mclawler