Chào cả nhà em có đọc trên diễn đàn bài viết trộn dữ liệu Excel sang file Word do anh MaiKa viết em muốn hỏi ở phần arrPath em muốn chỉ dẫn tới thư mục chứa file mẫu để trộn thư "D:\TronThu\FileMauDeTronThu" thay vì chọn như dưới thì sửa như thế nào . Nội dung code:
Sub MergeByVBA()
Dim WordApp As Object, wDoc As Object
Dim k&, rw&, Col&, arrF, Fullname, arrPath
Dim sPath$, sPathNew$, sFormat$
Dim Rng As Range
Dim fso As Object
On Error GoTo Thoat
Set Rng = Application.InputBox("Chon 1 cell bat ky cua dong can tron sang Word", Type:=8)
arrPath = Application.GetOpenFilename(Title:="Chon cac file doc can lam.", _
FileFilter:="Excel Files *.doc* (*.doc*),", MultiSelect:=True)
On Error GoTo Arr
If arrPath = False Then
MsgBox "Không có file nào.", vbExclamation, "Sorry!"
Exit Sub
Else
Arr:
sPath = Left(arrPath(1), InStrRev(arrPath(1), "\"))
rw = Rng.Row
Col = Range("XFD" & rw).End(xlToLeft).Column
arrF = Range("A4", Cells(4, Col)).Value
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
'
sPathNew = sPath
Set WordApp = CreateObject("Word.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Fullname In arrPath
Set wDoc = WordApp.Documents.Open(Fullname)
WordApp.Visible = False
On Error GoTo Ve
For k = 1 To Col
With WordApp.Selection.Find
.Text = arrF(1, k)
sFormat = GetFormat(Cells(rw, k))
If sFormat <> "0" Then
.Replacement.Text = Format(Cells(rw, k), sFormat)
Else
.Replacement.Text = Cells(rw, k)
End If
End With
WordApp.Selection.Find.Execute Replace:=wdReplaceAll
Next
If (Not fso.FolderExists(sPathNew)) Then fso.CreateFolder (sPathNew)
wDoc.SaveAs2 sPathNew & Range("G" & rw).Value & "-" & wDoc.Name
wDoc.Close False
Next
End If
MsgBox "Xong!"
Ve:
WordApp.Quit
Set wDoc = Nothing
Set WordApp = Nothing
Set fso = Nothing
Exit Sub
Thoat:
Set Rng = Nothing
End Sub
Sub MergeByVBA()
Dim WordApp As Object, wDoc As Object
Dim k&, rw&, Col&, arrF, Fullname, arrPath
Dim sPath$, sPathNew$, sFormat$
Dim Rng As Range
Dim fso As Object
On Error GoTo Thoat
Set Rng = Application.InputBox("Chon 1 cell bat ky cua dong can tron sang Word", Type:=8)
arrPath = Application.GetOpenFilename(Title:="Chon cac file doc can lam.", _
FileFilter:="Excel Files *.doc* (*.doc*),", MultiSelect:=True)
On Error GoTo Arr
If arrPath = False Then
MsgBox "Không có file nào.", vbExclamation, "Sorry!"
Exit Sub
Else
Arr:
sPath = Left(arrPath(1), InStrRev(arrPath(1), "\"))
rw = Rng.Row
Col = Range("XFD" & rw).End(xlToLeft).Column
arrF = Range("A4", Cells(4, Col)).Value
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
'
sPathNew = sPath
Set WordApp = CreateObject("Word.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Fullname In arrPath
Set wDoc = WordApp.Documents.Open(Fullname)
WordApp.Visible = False
On Error GoTo Ve
For k = 1 To Col
With WordApp.Selection.Find
.Text = arrF(1, k)
sFormat = GetFormat(Cells(rw, k))
If sFormat <> "0" Then
.Replacement.Text = Format(Cells(rw, k), sFormat)
Else
.Replacement.Text = Cells(rw, k)
End If
End With
WordApp.Selection.Find.Execute Replace:=wdReplaceAll
Next
If (Not fso.FolderExists(sPathNew)) Then fso.CreateFolder (sPathNew)
wDoc.SaveAs2 sPathNew & Range("G" & rw).Value & "-" & wDoc.Name
wDoc.Close False
Next
End If
MsgBox "Xong!"
Ve:
WordApp.Quit
Set wDoc = Nothing
Set WordApp = Nothing
Set fso = Nothing
Exit Sub
Thoat:
Set Rng = Nothing
End Sub
