求助，excel内容转到word中。

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

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