Xuất từ excel to word

boysanhdieu · 26/5/20

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

phuc12345 · 26/5/20

Bạn đưa lên file ví dụ cho dễ làm.

befaint · 26/5/20

boysanhdieu đã viết:
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 · 29/5/20

befaint đã viết:
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 · 30/5/20

boysanhdieu đã viết:
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 · 1/6/20

songmai đã viết:
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 · 1/6/20

boysanhdieu đã viết:
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 · 1/6/20

songmai đã viết:
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 · 1/6/20

tiniluu123 đã viết:
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

befaint · 1/6/20

boysanhdieu đã viết:
đã 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

Bạn chép cái đã sửa lên đây nhé.

songmai · 1/6/20

boysanhdieu đã viết:
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

boysanhdieu · 1/6/20

Em gửi 2 bác @befaint @songmai xem giúp, e chạy vẫn không ra

songmai · 1/6/20

boysanhdieu đã viết:
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 · 1/6/20

boysanhdieu đã viết:
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 · 1/6/20

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 · 1/6/20

boysanhdieu đã viết:
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

giaiphap · 1/6/20

boysanhdieu đã viết:
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 ạ

Sao vậy ta? máy tôi lưu đúng tên như ô AJ5 (0302436804.docx) mà bạn.

befaint · 2/6/20

boysanhdieu đã viết:
chạy vẫn không ra

Tải file, mở ra và click vào nút như hình dưới nhá.

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

VetMini · 2/6/20

befaint đã viết:
...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 · 2/6/20

befaint đã viết:
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: 2/6/20

giaiphap đã viết:

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

Xuất từ excel to word

Thành viên mới

Thành viên mới

|||||||||||||

Thành viên mới

Thành viên chính thức

Thành viên mới

Thành viên chính thức

Có bao giờ bạn tự hỏi "Tôi là ai?"

Thành viên mới

|||||||||||||

Thành viên chính thức

Thành viên mới

File đính kèm

Thành viên chính thức

==(^o^)==

Thành viên mới

Thành viên chính thức

==(^o^)==

|||||||||||||

File đính kèm

Ăn cùng góc phố

Thành viên mới