excel中是有很多条记录，
   然后每条记录生成一个如下格式的word文档，单独保存
   需要把excel的一些单元格内容自动填写到word的制定位置处，
   谢谢。

这个功能，使用 WORD 的邮件合并的功能进行操作。

看了你的文件，样式好乱啊。清了老半天。
你自己看看怎么打开吧。百度一下这个功能吧。

谢谢，我先看看

这个可以用，但生成的邮件能不能保存为单个的word呢，我试过了，好像不行呢

你需要一个记录，一个记录的 生成到文件里，不能 选择生成所有的记录。那样是会在一起的。

如果不是把文件发下去，可以不用生成。如果发下去的，临时生成就是了。
好像邮件合并可以合并到Email，但这个功能我没用过，不知道要不要与 outlook 配合使用。

这是无聊写的读出EXCEL的资料到结构中～之后的写入到WORD中还没动～就等高手了～也不是很难～会写巨集指令就行了～

form1

Option Explicit

Dim tmpName As String, xlsFilePath As String, xlsFileName As String, dotFileName As String
Dim XLSGetData As Boolean

Private Sub cmdChang_Click()
Dim FilePath As String
    
    If XLSGetData = True Then
        FilePath = Trim(Mid(xlsFilePath, 1, Len(xlsFilePath) - Len(xlsFileName)))
        Call InputWordData(FilePath, dotFileName)
    End If
    
End Sub

Private Sub OpenFile_Click()
Dim Status As Boolean

    Call NewProcess

    With Dialog1
        .Filter = "Office XLS File (" & tmpName & ")|" & tmpName & "|All Format Files (*.*)|*.*"
        .FilterIndex = 0
        .Flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNLongNames Or cdlOFNPathMustExist Or cdlOFNHideReadOnly Or cdlOFNNoChangeDir
        .InitDir = App.Path
        .ShowOpen
        xlsFilePath = .FileName
        
        If xlsFilePath <> "" Then
            txtFilePath.Text = xlsFilePath
            txtFilePath.ToolTipText = txtFilePath.Text
            xlsFileName = Mid(xlsFilePath, InStrRev(xlsFilePath, "\") + 1, Len(xlsFilePath) - InStrRev(xlsFilePath, "\"))
            Status = LoadExcelFileData(xlsFilePath, xlsFileName)
            
            If Status = True Then
                XLSGetData = True
            Else
                MsgBox "Excel Data Error !"
                XLSGetData = False
            End If
            
        Else
            MsgBox "Please Select a File !"
        End If
        
    End With
    
End Sub

Private Sub cmdBower_Click()
Dim Path As String

    Path = BrowseForFolder(Me.hwnd, "Select Project Save As Folder :", , 64)
    If (Trim(Path) <> "") Then
        txtTargetPath.Text = Path & "\"
    End If
    
End Sub

Private Sub Form_Load()

    If App.PrevInstance Then '避免程式執行兩次以上
       Call MsgBox("This program has been executed", vbCritical, "Warning")
       Unload Me
    End If
    
    SetCurrentDirectory App.Path
    
    tmpName = "*.xls"
    ProgressBar1.Min = 0
    ProgressBar1.Max = 100
    ProgressBar1.Value = 0
    
End Sub

Private Sub NewProcess()
    txtFilePath.Text = ""
    xlsFilePath = ""
    xlsFileName = ""
    dotFileName = ""
End Sub

Module:

Option Explicit

Public Type ExcelTableData
    ID As String
    ID_Card As String
    Telephone As String
    Agents As String
    Agents_ID_Card As String
    Agents_Telephone As String
    ID_Number As String
    Registration_Date As String
    Area As String
    Construction_Area As String
    Owners As String
End Type

Public Type UserData
    User() As ExcelTableData
    Rows As Integer
End Type
    
Private Type BROWSEINFOTYPE
    hOwner   As Long
    pidlRoot   As Long
    pszDisplayName   As String
    lpszTitle   As String
    ulFlags   As Long
    lpfn   As Long
    lParam   As Long
    iImage   As Long
End Type
  
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFOTYPE As BROWSEINFOTYPE) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long

Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA       As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW       As Long = (WM_USER + 103)
Private Const LPTR = (&H0 Or &H40)
  
Public Enum BROWSETYPE
    NONE = 0
    PATHTEXT = 16
    NEWFOLDER = 64
End Enum

Public EUser As UserData
Public ErrorCount As Long
Public ErrorData() As String
    
Private Sub BrowseCallbackProcStr(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long)
    If uMsg = 1 Then
        Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData)
    End If
End Sub
    
Private Function FunctionPointer(FunctionAddress As Long) As Long
    FunctionPointer = FunctionAddress
End Function

Public Function BrowseForFolder(ByVal hwnd As Long, ByVal strTitle As String, Optional selectedPath As String, Optional ByVal Flag As BROWSETYPE = 0) As String
Dim Browse_for_folder As BROWSEINFOTYPE
Dim itemID As Long
Dim selectedPathPointer As Long
Dim tmpPath As String * 256
            
    If selectedPath = "" Then selectedPath = ""                                                     '避免selectedPath未初始化而出錯
      
    If Not Right(selectedPath, 1) <> "\" Then
        selectedPath = Left(selectedPath, Len(selectedPath) - 1)                                    '如果用戶加了   "\"   則刪除
    End If
      
    With Browse_for_folder
    
        .hOwner = hwnd                                                                              '所有都視窗之控制碼
        .lpszTitle = strTitle                                                                       '對話方塊的標題
        .ulFlags = Flag
        .lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr)                                    '用於設置預設檔夾的回調函數
        selectedPathPointer = LocalAlloc(LPTR, Len(selectedPath) + 1)                               '分配一個字串記憶體
        Call CopyMemory(ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1)       '拷貝那個路徑到記憶體
        .lParam = selectedPathPointer                                                               '預設的文件夾
            
    End With
    
    itemID = SHBrowseForFolder(Browse_for_folder)                                                   '執行API函數：BrowseForFolder
    
    If itemID Then
        If SHGetPathFromIDList(itemID, tmpPath) Then                                                '取得選定的檔夾
                BrowseForFolder = Left(tmpPath, InStr(tmpPath, vbNullChar) - 1)                     '去掉多餘的   null   字元
        End If
        
        Call CoTaskMemFree(itemID)                                                                  '釋放記憶體
        
    End If
    
    Call LocalFree(selectedPathPointer)                                                             '釋放記憶體
    
End Function

Public Function LoadExcelFileData(FilePath As String, FileName As String) As Boolean
Dim xlapp As New Excel.Application                                                                  '定義EXCEL類
Dim xlBook As Excel.Workbook                                                                        '定義工件簿類
Dim xlsheet As Excel.Worksheet                                                                      '定義工作表類
Dim fs As New FileSystemObject
Dim SheetName As String, File
Dim i As Long, k As Long
Dim DataStatus As Boolean

On Error GoTo ErrorHandling

    DataStatus = False: LoadExcelFileData = False: i = 1
    
    Set xlapp = CreateObject("Excel.Application")
'    xlapp.Visible = True                                                                           '設置EXCEL可見
    xlapp.Visible = False                                                                           '設置EXCEL可見
    Set xlBook = xlapp.Workbooks.Open(FilePath)
    Set xlsheet = xlBook.Sheets(1)
    
    SheetName = xlsheet.Name
    xlsheet.Activate
    
    If UCase(SheetName) = UCase("Export_Output_3") Then
        
        With xlsheet
        
            Do While (Trim(.Cells(1, i)) <> "" Or DataStatus = True)                                '判斷欄位是否有值
                
                i = i + 1
                
                If IsNumeric(.Cells(i - 1, 1)) = True Then
                
                    ReDim Preserve EUser.User(EUser.Rows)
                    EUser.Rows = EUser.Rows + 1                                                     '記錄Sheet下的所有Row的欄位的有值筆數
                    DataStatus = True
                
                    Do While (Trim(.Cells(i, 1)) <> "" Or DataStatus = True)                        '判斷欄位是否有值
                        With EUser.User(EUser.Rows - 1)
                        
                            .ID = xlsheet.Cells(i - 1, 1)
                            .ID_Card = xlsheet.Cells(i - 1, 2)
                            .Telephone = xlsheet.Cells(i - 1, 3)
                            .Agents = xlsheet.Cells(i - 1, 4)
                            .Agents_ID_Card = xlsheet.Cells(i - 1, 5)
                            .Agents_Telephone = xlsheet.Cells(i - 1, 6)
                            .ID_Number = xlsheet.Cells(i - 1, 7)
                            .Registration_Date = xlsheet.Cells(i - 1, 8)
                            .Area = xlsheet.Cells(i - 1, 9)
                            .Construction_Area = xlsheet.Cells(i - 1, 10)
                            .Owners = xlsheet.Cells(i - 1, 11)
                            
                        End With
                        
                        Exit Do
                    Loop
                Else
                    DataStatus = False
                End If
                
                DoEvents
                
                If Trim(Cells(i - 1, 2)) <> "" And EUser.Rows > 5 Then Exit Do
            Loop
            
        End With
        
        LoadExcelFileData = True
        
    End If
    
Exit Function

ErrorHandling:
    Call ErrorWriteBuff(FileName, i, "LoadExcelFileData", Err.Number, Err.Description, "系統訊息")
    Resume Next
End Function

Public Function InputWordData(FilePath As String, FileName As String) As Boolean
Dim StartNum As Integer, StartNum1 As Integer, i As Long, k As Long

On Error GoTo ErrorHandling

    'Write Struct Data to Word

Exit Function

ErrorHandling:
    Call ErrorWriteBuff(FileName, i, "LoadExcelFileData", Err.Number, Err.Description, "系統訊息")
    Resume Next
End Function

Public Function ErrorWriteBuff(FileName As String, lines As Long, FunctionName As String, code As Integer, Description As String, Remarks As String) As Boolean
    
    If Description = "" Then
        Description = "Null"
    End If
    
    ReDim Preserve ErrorData(ErrorCount)
    ErrorData(ErrorCount) = FileName & ":" & Format(lines, "00000000") & "  " & FunctionName & "  " & "code :" & code & " Description :" & Description & ":" & Remarks
    ErrorCount = ErrorCount + 1
    
End Function

你的资料排版还真的是让人无言～我改了一下～



P.S Word档案要依照EXCEL的资料笔数输出的话～你的Word档案～必须改拓展名～改成范本专用*.dot～这样每次去呼叫那个dot就自动会生成一个新的doc的档了～
意义同于EXCEL的范本*.xlt～

P.S 当然这招式写死的～因为你的Word档案是死的～也有可以写活的～所以看情况～偷改一下一行～写错位置～结果差很多～

[ 本帖最后由 wube 于 2011-5-25 23:47 编辑 ]

虽然WORD可以录巨集～但是差好多一下转不过来～还在想～该不会是EXCEL的比WORD简单吧～
几乎没碰过WORD～但是我有信心～一定很简单～

P.S 我说WORD应该都有Table～不然怎定位写值～你的WORD可能要改改～不然没Table的部份我还真不知道怎算它空格的位置～

[ 本帖最后由 wube 于 2011-5-25 22:45 编辑 ]

谢谢各位，

这几款pdf转换软件好用

免费下载pdf转换成word转换器 http://www.　

pdf转换成word http://www.

另外这款word转换成pdf格式转换器也很好用万能word转pdf转换器 http://www.

 

pdf转换成ppt软件 http://www.
将pdf转换成ppt  http://www.
pdf转ppt格式转换器  http://www.
pdf转换成excel http://www.
pdf转换成word转换器 http://dl.
pdf转换成word转换器 http://www.
pdf转换成word转换器 http://www.
pdf转换成word转换器 http://soft.
pdf转换成word转换器 http://www.
pdf转换成word转换器 http://www.
pdf转换成word转换器 http://www.