求助,excel内容转到word中。
excel中是有很多条记录,
然后每条记录生成一个如下格式的word文档,单独保存
需要把excel的一些单元格内容自动填写到word的制定位置处,
谢谢。
样本.zip
(33.97 KB)
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