麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub 結束匯出()
Dim Rng As Range
Set Rng = Sheets("紀錄").[A2]
With CreateObject("Word.APPLICATION")
.Visible = True
.Documents.Open ("完整的路徑檔案名稱.doc")
With .ActiveDocument.Tables(1) 'Word檔案中第一個表格
.Cell(1, 1) = Rng(1, 1) '姓名
.Cell(1, 2) = Rng(1, 2) '編號
.Cell(1, 3) = Rng(1, 3) '部門
'.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
End With
.ActiveDocument.Close True
.Quit
End With
Rng.Resize(1, 7) = "" '轉換後記錄頁面的資料清空
End Sub

複製代碼

Option Explicit
Sub 結束匯出()
Dim RNG As Range, ss As Object
Set RNG = Sheets("紀錄").[A2]
With CreateObject("Word.APPLICATION")
.Visible = True
.Documents.Open (ThisWorkbook.Path & "\1.doc")
Set ss = .ActiveDocument.Sentences(1)
'*** Word VBA: Sentences 集合物件請參閱屬性方法事件特定多重物件
'這是由 Range 物件所組成的集合，代表選取範圍、範圍或文件中的所有句子。沒有所謂 Sentence 物件。
.ActiveDocument.Range(InStr(ss, "："), Len(ss) - 1) = RNG(1, 2)
'文件編號
With .ActiveDocument.Tables(1) 'Word檔案中第一個表格
' .Cell(2, 1) = Rng(1, 1) '項次 '*** 清單的哪一項***
.Cell(2, 2) = RNG(1, 3) '發行日期
.Cell(2, 3) = RNG(1, 4) 'Product code
.Cell(2, 4) = RNG(1, 5) '客戶
.Cell(2, 5) = RNG(1, 6) 'Product code
.Cell(2, 6) = RNG(1, 7) 'Lot id
.Cell(2, 7) = RNG(1, 8) 'line
.Cell(2, 8) = RNG(1, 9) 'Qty
.Cell(4, 2) = RNG(1, 10) '內容
.Cell(5, 3) = RNG(1, 11) '收件日期
.Cell(5, 7) = RNG(1, 12) '核對人
.Cell(9, 4) = RNG(1, 13) 'Detail Explain
'.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
End With
.ActiveDocument.SaveAs Filename:="D:\OK.doc" '*** WORD匯出 ***
'.ActiveDocument.Close True
.Quit
End With
'Rng.Resize(1, 13) = "" '轉換後記錄頁面的資料清空
End Sub

複製代碼

Option Explicit
Dim Word檔 As String '匯出word檔,存檔的名稱
Dim 紀錄 As Range
Sub 匯出word() '由清單複製後匯出word檔
Set 紀錄 = Sheets("紀錄").[c2:m2]
MsgBox Application.CountA(紀錄)
If Application.CountA(紀錄) <> 11 Then
MsgBox "資料不齊全": Exit Sub
Else
Do
Word檔 = Application.InputBox("*.doc", "匯出word檔,存檔的名稱")
Loop While Word檔 = "False" Or Word檔 = ""
If Not InStr(LCase(Word檔), "*.doc") Then Word檔 = Word檔 & ".doc"
End If
Main
清單檢查
End Sub
Sub 清單檢查() '檢查紀錄不存在: 詢問是否加入
Dim R As Integer, E As Range, MM As String
Set 紀錄 = Sheets("紀錄").[c2:m2]
With Sheets("清單")
R = .Cells(.Rows.Count, "c").End(xlUp).Row '清單:紀錄的列數
If R = 1 Then
GoTo OK
Else
MM = Join(Application.Transpose(Application.Transpose(紀錄.Value)), vbLf)
For Each E In .Range("C2:M2").Resize(R - 1).Rows
If MM = Join(Application.Transpose(Application.Transpose(E.Value)), vbLf) Then GoTo EE
Next
End If
OK:
If MsgBox(MM, vbYesNo, "記錄: 存入清單..") = vbYes Then
紀錄.Copy .Cells(R + 1, "c") '複製到紀錄的列數+1
.Cells(R + 1, "B").NumberFormatLocal = "@"
.Cells(R + 1, "B").FormulaR1C1 = Format(R + 1, "000")
End If
EE:
紀錄.EntireRow = "" '轉換後記錄頁面的資料清空
End With
End Sub
Sub 複製到紀錄()
Dim Rng As Range
With Sheets("清單")
Set Rng = .Range("a1").CurrentRegion.Rows(2)
Set Rng = Rng.Resize(.Range("a1").CurrentRegion.Rows.Count - 1)
If Not Application.Intersect(Rng, ActiveCell) Is Nothing Then
.Range("A" & ActiveCell.Row & ":" & "M" & ActiveCell.Row).Copy Sheets("紀錄").Range("A2")
MsgBox "編號: " & vbTab & "[" & .Range("B" & ActiveCell.Row) & "]", , "複製到紀錄!!"
Else
MsgBox "需選擇在清單的範圍"
Rng.Select
End If
End With
End Sub
Private Sub Main() '記錄匯出到word檔
With CreateObject("Word.APPLICATION")
.Visible = True
' .Documents.Open ("\\Tctk0fi25\oqa_report$\04_異常處理表單_R3\不合格單開立區\1.doc")
.Documents.Open (ThisWorkbook.Path & "\1.doc")
With .ActiveDocument.Tables(1) 'Word檔案中第一個表格
' .Cell(2, 1) = Rng(1, 1) '項次
'.Cell(2, 2) = Rng(1, 2) '編號
.Cell(2, 2) = 紀錄(1, 1) '發行日期
.Cell(2, 3) = 紀錄(1, 2) 'Product code
.Cell(2, 4) = 紀錄(1, 3) '客戶
.Cell(2, 5) = 紀錄(1, 4) 'Product code
.Cell(2, 6) = 紀錄(1, 5) 'Lot id
.Cell(2, 7) = 紀錄(1, 6) 'line
.Cell(2, 8) = 紀錄(1, 7) 'Qty
.Cell(4, 2) = 紀錄(1, 8) '內容
.Cell(5, 3) = 紀錄(1, 9) '收件日期
.Cell(5, 7) = 紀錄(1, 10) '核對人
.Cell(9, 4) = 紀錄(1, 11) 'Detail Explain
'.Cell(?, ?)= 職稱 ,年資 , 紀錄, 面談者:餘下資料請自行填入
End With
.ActiveDocument.SaveAs Filename:="D:\TEST\" & Word檔 '*** WORD匯出 ***
.ActiveDocument.Close '關閉word檔 'True
.Quit '關閉word應用程式
End With
End Sub

複製代碼