关于Excel和邮件合并提高工作效率求助！能帮我解决这个问题 感激不尽！！！

44840075

继续我之前的贴子，问题已经解决了。 http://club.excelhome.net/forum.php?mod=viewthread&tid=1501961&page=1#pid10103736这里面说是做好的Excel，现在已经用程序做出来了， 给大家看看一键生产Excel的效果，https://jxjjxy-my.sharepoint.com/:v:/g/personal/1327237842_t_odmail_cn/EXBXfUD98lBLo31dxMsABVMBONcwIKQOLHvqJiiMpgve-g?e=IjiO9r 不过我还有一个问题，word的邮件合并能不能批量做，假如我做一个邮件合并需要1分钟，我有100个需要做我得花100分钟，有什么思路快点吗？ 求建议，以及思路，用于邮件合并，这个，相当于，序号，文件名，图片，写到一个word里面

zpy2

这个onedriver不错啊，是商业付费版吗？
另外，合并太多不如在线查询一下。

xyxcc177

1分钟的邮件合并，得有多少数据？

youzhenhappy

Sub 提取文件名()
    Dim Fso As Object, Folder_0 As Object, Folder_1 As Object, File As Object
    Dim NWkb As Workbook
    Dim KeyArr
    Dim FileNameArr() As String

    Dim FilePaths As String, FileNames As String, Path  As String, FolderPath As String
    Dim NWkbName As String
    Dim i As Long, j As Long

    Set objFD = Application.FileDialog(msoFileDialogFolderPicker)
    With objFD
        .InitialFileName = ActiveWorkbook.Path
        If .Show = -1 Then
            Path = .SelectedItems(1) '如果单击了确定按钮，则将选取的路径保存在变量中
        Else
            End   '否则结束程序
        End If
    End With

    Set Fso = CreateObject("scripting.filesystemobject") '创建FSO对象
    Set Folder_0 = Fso.GetFolder(Path)

    Set D = CreateObject("Scripting.Dictionary")    '创建字典

    '--------------------获取选择路径下，子文件夹路径及其文件名-----------------
    i = 0
    For Each Folder_1 In Folder_0.SubFolders '遍历根文件夹下的文件
        FolderPath = Folder_1.Path

        For Each File In Folder_1.Files
            FileNames = FileNames & File.Name & "\"
        Next

        FileNames = Left(FileNames, Len(FileNames) - 1)
        'MsgBox FileNames

        If Not D.Exists(FolderPath) Then          '判断关键字是否存在
            D.Add FolderPath, FileNames
        End If
        FileNames = ""
    Next
    '--------------------------------------------------------------------------

    '-------------------------获取选择路径下，文件名---------------------------
    FileNames = ""
    For Each File In Folder_0.Files
        FileNames = FileNames & File.Name & "\"
    Next
    FileNames = Left(FileNames, Len(FileNames) - 1)
    If Not D.Exists(Path) Then          '判断关键字是否存在
        D.Add Path, FileNames
    End If
    '--------------------------------------------------------------------------
    KeyArr = D.keys

    For i = LBound(KeyArr) To UBound(KeyArr)
        Set NWkb = Workbooks.Add
        NWkbName = Right(KeyArr(i), Len(KeyArr(i)) - InStrRev(KeyArr(i), "\"))
        NWkb.SaveAs KeyArr(i)
        NWkb.Worksheets("Sheet1").Name = NWkbName

        NWkb.Worksheets(NWkbName).Cells(1, 2) = "名称"
        NWkb.Worksheets(NWkbName).Cells(1, 1) = "序"

        FileNameArr = Split(D(KeyArr(i)), "\")
        For j = LBound(FileNameArr) To UBound(FileNameArr)
            With NWkb.Worksheets(NWkbName)
                .Cells(j + 2, 2) = FileNameArr(j)
                .Cells(j + 2, 1) = j + 1
            End With
        Next j
        NWkb.Save
        NWkb.Close

    Next i




End Sub