Xuất từ excel to word

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Các bác cho mình hỏi, mình có code VBA sau nhưng khi kết xuất từ excel sang word nó không tự save as như đường dẫn trong code, các bác chỉ giáo giúp
Với lại mình muốn nó tự đạt tên theo số liệu của 1 ô cố định nào đó trong sheet thì làm ntn?
Thanks các bác
Mã:
Sub Export_to_Word()
Dim wdapp As Object, wddoc As Object
Dim strdocname As String
On Error Resume Next
Sheet7.Range("B1:G57").Copy
Set wdapp = GetObject(, "word.Application")
If Err.Number = 429 Then
    Err.Clear
    Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
wdapp.Active
Set wddoc = wdapp.Documents.Add
wddoc.Active
wddoc.Range.PasteSpecial xlPasteValues
Set wddoc = Nothing
Set wdapp = Nothing
wddoc.SaveAs (Application.ThisWorkbook.Path & "\abc.docx")
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
 

befaint

|||||||||||||
Tham gia ngày
6 Tháng một 2011
Bài viết
10,028
Được thích
11,793
Điểm
1,560
Set wddoc = Nothing '-> Xóa nó rồi còn đâu nữa mà dùng
Set wdapp = Nothing
wddoc.SaveAs (Application.ThisWorkbook.Path & "\abc.docx")
Const extension_doc = ".docx"
Dim new_name as string
new_name = Sheet7.Range("A1").value2 & extension_doc 'Giả sử tên theo ô A1
'...
wddoc.SaveAs (Application.ThisWorkbook.Path & "\" & new_name
Set wddoc = Nothing
Set wdapp = Nothing
 

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Const extension_doc = ".docx"
Dim new_name as string
new_name = Sheet7.Range("A1").value2 & extension_doc 'Giả sử tên theo ô A1
'...
wddoc.SaveAs (Application.ThisWorkbook.Path & "\" & new_name
Set wddoc = Nothing
Set wdapp = Nothing
Bạn ơi, bạn có thể viết thành code hoàn chỉnh không, mình không biết ráp vô chổ nào
Thanks
 

songmai

Thành viên chính thức
Tham gia ngày
6 Tháng tám 2007
Bài viết
92
Được thích
36
Điểm
670
Bạn ơi, bạn có thể viết thành code hoàn chỉnh không, mình không biết ráp vô chổ nào
Cảm ơn
Bạn tự mày mò chút chứ ăn sẵn mãi có tiến bộ được đâu. Code của bạn ban đầu sai ở chỗ đã Set wddoc = Nothing rồi thì làm sao nó hoạt động được nữa mà chạy Save as?
 

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Bạn tự mày mò chút chứ ăn sẵn mãi có tiến bộ được đâu. Code của bạn ban đầu sai ở chỗ đã Set wddoc = Nothing rồi thì làm sao nó hoạt động được nữa mà chạy Save as?
Bạn ơi, nếu mình có học wa VBA thì mình làm rồi, mình mò không ra nên mới lên đây hỏi.
Bạn Befaint có sửa nhưng mình không hiểu nên mới hỏi
 

songmai

Thành viên chính thức
Tham gia ngày
6 Tháng tám 2007
Bài viết
92
Được thích
36
Điểm
670
Bạn ơi, nếu mình có học wa VBA thì mình làm rồi, mình mò không ra nên mới lên đây hỏi.
Bạn Befaint có sửa nhưng mình không hiểu nên mới hỏi
Thì bạn cứ học đi! Dùng VBA mà không tùy biến được code, chẳng mỗi lần thay đổi cấu trúc dữ liệu đầu vào 1 chút hoặc thay đổi yêu cầu đầu ra 1 tí lại phải đi hỏi?
 

tiniluu123

Có bao giờ bạn tự hỏi "Tôi là ai?"
Tham gia ngày
25 Tháng một 2019
Bài viết
192
Được thích
100
Điểm
180
Nơi ở
Mỹ Tho- Tiền Giang
Bạn tự mày mò chút chứ ăn sẵn mãi có tiến bộ được đâu. Code của bạn ban đầu sai ở chỗ đã Set wddoc = Nothing rồi thì làm sao nó hoạt động được nữa mà chạy Save as?
Người ta nói lời thật dễ mất lòng, hi.
Biết nói sao bây giờ đây. Tôi đầy thông cảm với chủ thớt. Tôi cũng hiểu quan điểm của bạn @songmai !
 

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Người ta nói lời thật dễ mất lòng, hi.
Biết nói sao bây giờ đây. Tôi đầy thông cảm với chủ thớt. Tôi cũng hiểu quan điểm của bạn @songmai !
Thank bạn, từ đầu thì bạn @befaint đã cho mình biết lỗi
Set wddoc = Nothing '-> Xóa nó rồi còn đâu nữa mà dùng
Set wdapp = Nothing
wddoc.SaveAs (Application.ThisWorkbook.Path & "\abc.docx")
mình đã chỉnh sửa công thức lại, nó chạy không báo lỗi nhưng không tự đặt tên theo đk 1 ô cố định trong sheet
còn bác @songmai lập lại lời của @befaint để làm gì không biết, vô đây cũng để cùng nhau học tập thôi chứ đâu? Mình không biết thì hỏi, bạn nào biết thì chỉ, mình cám ơn vậy thôi
Thanks các bác
 

songmai

Thành viên chính thức
Tham gia ngày
6 Tháng tám 2007
Bài viết
92
Được thích
36
Điểm
670
Thank bạn, từ đầu thì bạn @befaint đã cho mình biết lỗi
Set wddoc = Nothing '-> Xóa nó rồi còn đâu nữa mà dùng
Set wdapp = Nothing
wddoc.SaveAs (Application.ThisWorkbook.Path & "\abc.docx")
mình đã chỉnh sửa công thức lại, nó chạy không báo lỗi nhưng không tự đặt tên theo đk 1 ô cố định trong sheet
còn bác @songmai lập lại lời của @befaint để làm gì không biết, vô đây cũng để cùng nhau học tập thôi chứ đâu? Mình không biết thì hỏi, bạn nào biết thì chỉ, mình cám ơn vậy thôi
Cảm ơn các bác
Đã chạy OK.
PHP:
Sub Export_to_Word()
Dim wdapp As Object, wddoc As Object
Dim strdocname As String
Const extension_doc = ".docx"
Dim new_name As String
new_name = Sheet7.Range("A1") & extension_doc 'Sua lai dia chi cell neu muon

On Error Resume Next
Sheet7.Range("B1:G57").Copy
Set wdapp = GetObject(, "word.Application")

If Err.Number = 429 Then
    Err.Clear
    Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
Set wddoc = wdapp.Documents.Add
wddoc.Activate  'Cho nay ban dau la wddoc.Active -> khong chay duoc nhung bi dong On Error Resume Next can thiep nen cho qua
wddoc.Range.PasteSpecial xlPasteValues
wddoc.SaveAs (Application.ThisWorkbook.Path & "\" & new_name)
Set wddoc = Nothing
Set wdapp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
 

songmai

Thành viên chính thức
Tham gia ngày
6 Tháng tám 2007
Bài viết
92
Được thích
36
Điểm
670
Em gửi 2 bác @befaint @songmai xem giúp, e chạy vẫn không ra
Tải file bạn về chạy OK mà (chỉ lưu ý vùng dữ liệu là A1:AE54 chứ không phải là B1:AE54).

Bạn chạy không ra là sao:
- Có báo lỗi không?
- Không thấy file Word?
- File Word trắng, không có chữ nào?

(Bạn cần mô tả lỗi để người khác có thể giúp bạn tốt hơn, nhanh hơn chứ không mất công đi đoán mò giùm bạn)
 

giaiphap

==(^o^)==
Tham gia ngày
12 Tháng ba 2007
Bài viết
5,238
Được thích
4,875
Điểm
860
Em gửi 2 bác @befaint @songmai xem giúp, e chạy vẫn không ra
Tôi chạy code này của bạn ra bình thường.
Mã:
Sub Export_to_Word()
Dim wdapp As Object, wddoc As Object
Dim strdocname As String
Const extension_doc = ".docx"
Dim new_name As String
new_name = Sheet1.Range("AJ5") & extension_doc 'Sua lai dia chi cell neu muon

On Error Resume Next
Sheet1.Range("A1:AE54").Copy
Set wdapp = GetObject(, "word.Application")

If Err.Number = 429 Then
    Err.Clear
    Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
Set wddoc = wdapp.Documents.Add
wddoc.Activate  'Cho nay ban dau la wddoc.Active -> khong chay duoc nhung bi dong On Error Resume Next can thiep nen cho qua
wddoc.Range.PasteSpecial xlPasteValues
wddoc.SaveAs Application.ThisWorkbook.Path & "\" & new_name
Set wddoc = Nothing
Set wdapp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Chú ý sửa trong code của bạn chổ
Mã:
Sheet1.Range("B1:AE54").Copy
thành
Mã:
Sheet1.Range("A1:AE54").Copy
 

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Nó không đặt tên theo định dạng tại ô AJ5 và lưu file theo đường dẫn thư mục gốc các bác ạ
 

songmai

Thành viên chính thức
Tham gia ngày
6 Tháng tám 2007
Bài viết
92
Được thích
36
Điểm
670
Nó không đặt tên theo định dạng tại ô AJ5 và lưu file theo đường dẫn thư mục gốc các bác ạ
File bạn có 2 thủ tục cùng tên Export_to_Word ở 2 vị trí khác nhau. Bạn xóa thủ tục ở sheet1 đi, để lại Export_to_Word ở Module1. Lý do không chắc là ở đó nhưng cứ thử vì máy tôi chạy bình thường dù xóa hay không
 

VetMini

Chuyên gia GPE
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
10,170
Được thích
12,342
Điểm
1,560
...Cái này người ta lưu thành file PDF mới hợp lý chứ?
Ở GPE từ "hợp lý" gần như không bao giờ được hiểu theo tính cách khách quan.
Hồi nào giờ bạn có hề thấy thớt nào mà không có câu "trường hợp của em nó đặc thù..." hôn?

Với số lượng hằng trăm ngàn bài trên GPE, tôi đánh cuộc với bạn, chỉ cần đưa ra được đến 3 bài mà chủ thớt chịu nghe theo lời khuyên "hợp lý" thì tôi sẽ thua bạn một chầu phở tái.
 

boysanhdieu

Thành viên mới
Tham gia ngày
13 Tháng mười 2008
Bài viết
22
Được thích
4
Điểm
665
Tuổi
37
Tải file, mở ra và click vào nút như hình dưới nhá.

View attachment 238484

----
Cái này người ta lưu thành file PDF mới hợp lý chứ?
Option Explicit

Sub Export_to_Word()
Const extension_docx As String = ".docx"
Const extension_doc As String = ".doc"
Const rng_copy As String = "A1:AE54"
Const scell_name As String = "AJ5"

Dim wdapp As Object, wddocx As Object, wddoc As Object
Dim docx_name As String
Dim doc_name As String

docx_name = ThisWorkbook.Path & "\" & Sheet1.Range(scell_name).Value2 & extension_docx
doc_name = ThisWorkbook.Path & "\" & Sheet1.Range(scell_name).Value2 & extension_doc

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Sheet1.Activate
Sheet1.Range(rng_copy).Copy

Set wdapp = CreateObject("Word.Application")
Set wddocx = wdapp.Documents.Add
Set wddoc = wdapp.Documents.Add
With wddocx
.Range.PasteSpecial xlPasteValues
.SaveAs docx_name báo lỗi bác @befaint
.Close
End With

With wddoc
.Range.PasteSpecial xlPasteValues
.SaveAs doc_name
.Close
End With
'clean up
Set wddocx = Nothing: Set wddoc = Nothing
Set wdapp = Nothing
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!", vbInformation
End Sub
Bài đã được tự động gộp:

Tôi chạy code này của bạn ra bình thường.
Mã:
Sub Export_to_Word()
Dim wdapp As Object, wddoc As Object
Dim strdocname As String
Const extension_doc = ".docx"
Dim new_name As String
new_name = Sheet1.Range("AJ5") & extension_doc 'Sua lai dia chi cell neu muon

On Error Resume Next
Sheet1.Range("A1:AE54").Copy
Set wdapp = GetObject(, "word.Application")

If Err.Number = 429 Then
    Err.Clear
    Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
Set wddoc = wdapp.Documents.Add
wddoc.Activate  'Cho nay ban dau la wddoc.Active -> khong chay duoc nhung bi dong On Error Resume Next can thiep nen cho qua
wddoc.Range.PasteSpecial xlPasteValues
wddoc.SaveAs Application.ThisWorkbook.Path & "\" & new_name
Set wddoc = Nothing
Set wdapp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Chú ý sửa trong code của bạn chổ
Mã:
Sheet1.Range("B1:AE54").Copy
thành
Mã:
Sheet1.Range("A1:AE54").Copy
Nó vẫn ko đặt tên bác ạ @songmai @giaiphap , chắc lỗi do máy của mình
1591069056882.png
 
Lần chỉnh sửa cuối:
Top Bottom