Kết xuất nội dung 1 ô ra file text

Liên hệ QC

MinhKhai

Giải pháp Ếc-xào
Tham gia
16/4/08
Bài viết
934
Được thích
568
Kính chào các anh chị
Em muốn nhờ các anh chị am hiểu về VBA giúp đỡ. Nội dung em đã mô tả trong file đính kèm
Cụ thể là: Em muốn dùng VBA kết xuất nội dụng của 1 ô ra file .txt với tên file và đường dẫn lưu file được chỉ định sẵn.
Lưu ý: Em cần các dòng xuống hàng giống như trong ô và không có dấu "" bọc đoạn văn như khi copy thông thường
Em đã tham khảo tại https://chandoo.org/wp/2015/10/28/save-range-as-text-using-vba/ nhưng không làm được như mong muốn.
Rất mong được giúp đỡ.
Trân trọng cảm ơn
 

File đính kèm

  • FZE Editor.xlsb
    71.4 KB · Đọc: 13
Mã:
Private Sub CommandButton1_Click()
Dim Path As String, Rng As Range, Cll As Range, Tem, J As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet1
Path = .Range("J1").Value & "\" 'ThisWorkbook.Path
Set Rng = .Range("H4:H101")
For Each Cll In Rng
If Cll.Value <> Empty Then
Tem = Split(Cll.Value, Chr(10))
    Workbooks.Add
    With ActiveWorkbook
        For J = LBound(Tem) To UBound(Tem)
            .Sheets(1).Range("A1").Offset(J).Value = Tem(J)
        Next
        .SaveAs filename:=Path & Format(Now, "yyyymmdd") & "-" & Cll.Offset(, -7).Value & ".txt", FileFormat:=xlUnicodeText
        .Close True
    End With
    Cll.Offset(, 2).Value = "Message Sent " & Format(Now, "dd/mm/yyyy h:mm:ss AM/PM")
    Cll.Offset(, 3).Value = Format(Now, "yyyymmdd") & "-" & Cll.Offset(, -7).Value
End If
Next
End With
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Upvote 0
Mã:
Private Sub CommandButton1_Click()
Dim Path As String, Rng As Range, Cll As Range, Tem, J As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet1
Path = .Range("J1").Value & "\" 'ThisWorkbook.Path
Set Rng = .Range("H4:H101")
For Each Cll In Rng
If Cll.Value <> Empty Then
Tem = Split(Cll.Value, Chr(10))
    Workbooks.Add
    With ActiveWorkbook
        For J = LBound(Tem) To UBound(Tem)
            .Sheets(1).Range("A1").Offset(J).Value = Tem(J)
        Next
        .SaveAs filename:=Path & Format(Now, "yyyymmdd") & "-" & Cll.Offset(, -7).Value & ".txt", FileFormat:=xlUnicodeText
        .Close True
    End With
    Cll.Offset(, 2).Value = "Message Sent " & Format(Now, "dd/mm/yyyy h:mm:ss AM/PM")
    Cll.Offset(, 3).Value = Format(Now, "yyyymmdd") & "-" & Cll.Offset(, -7).Value
End If
Next
End With
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Tuyệt vời bác ơi. Cảm ơn bác nhiều
Bác cho hỏi 1 câu nho nhỏ là: Bác làm là chỉ với 1 bấm chuột là ra hết các file, nhưng file này em update hàng ngày, hàng giờ nên muốn mỗi lần bấm chuột chỉ 1 dòng (1 file) tạo ra thôi.
Nếu bấm 1 lần nó ra tất cả, thì khi update thêm dữ liệu, rồi bấm nút thì nó sẽ lại tạo ra lô file mới bị trùng nội dung.
Rất mong bác giúp thêm lần nữa.
Cảm ơn bác nhiều
 
Upvote 0
Code trong module:
PHP:
Sub WriteText(Cll As Range)
    Dim sFile As String
    sFile = Format(Date, "yyyymmdd") & "-" & Cll.Offset(, -8).Value
    CreateObject("Scripting.FileSystemObject").CreateTextFile([J1] & "\" & sFile & ".txt").Write Replace(Cll.Offset(, -1), ChrW(10), vbNewLine)
    Cll.Offset(, 1).Value = "Message Sent " & Format(Now, "dd/mm/yyyy h:mm:ss AM/PM")
    Cll.Offset(, 2).Value = sFile
End Sub
Code cho CommandButton1:
PHP:
Private Sub CommandButton1_Click()
WriteText ActiveCell
End Sub
 
Upvote 0
Code trong module:
PHP:
Sub WriteText(Cll As Range)
    Dim sFile As String
    sFile = Format(Date, "yyyymmdd") & "-" & Cll.Offset(, -8).Value
    CreateObject("Scripting.FileSystemObject").CreateTextFile([J1] & "\" & sFile & ".txt").Write Replace(Cll.Offset(, -1), ChrW(10), vbNewLine)
    Cll.Offset(, 1).Value = "Message Sent " & Format(Now, "dd/mm/yyyy h:mm:ss AM/PM")
    Cll.Offset(, 2).Value = sFile
End Sub
Code cho CommandButton1:
PHP:
Private Sub CommandButton1_Click()
WriteText ActiveCell
End Sub
Chính xác là những điều em muốn. Không biết nói gì hơn là cảm ơn bác.
Trong 1 file của em có nhiều sheet có cấu trúc giống hệt nhau (như file đính kèm ban đầu). Không biết nếu sử dụng chung code trong modul không thì sửa như nào ạ ?
Một lần nữa em xin cảm ơn
 
Upvote 0
Cấu trúc giống nhau thì không cần sửa gì đâu bạn.
 
Upvote 0
Code trong module:
PHP:
Sub WriteText(Cll As Range)
    Dim sFile As String
    sFile = Format(Date, "yyyymmdd") & "-" & Cll.Offset(, -8).Value
    CreateObject("Scripting.FileSystemObject").CreateTextFile([J1] & "\" & sFile & ".txt").Write Replace(Cll.Offset(, -1), ChrW(10), vbNewLine)
    Cll.Offset(, 1).Value = "Message Sent " & Format(Now, "dd/mm/yyyy h:mm:ss AM/PM")
    Cll.Offset(, 2).Value = sFile
End Sub
Code cho CommandButton1:
PHP:
Private Sub CommandButton1_Click()
WriteText ActiveCell
End Sub

Kính gửi bác @huuthang_bd

Code của bác đã giúp công việc của em khá tốt. Tuy nhiên có 1 lỗi rất ngớ ngẩn xuất phát từ người dùng mà em không biết cách xử lý (bẫy lỗi).

Mô tả lỗi: Nếu đặt sẵn nút lệnh ở cột O hoặc P, sau đó mới nhập dữ liệu ở dòng tương ứng. Ngay sau khi nhập liệu vừa đủ, người dùng bấm nút là Code hoạt động sai vì nó xác định ActiveCell không như mình nghĩ.
Hoặc sau khi nhập liệu xong, người dùng di chuyển nút vào vị trí để bấm, nhưng thực tế họ không bấm ngay mà cho trỏ chuột đi đâu đó. Sau đó họ lại bấm nút lệnh thì ActiveCell thực tế không còn như tính toán nữa để code chạy như mong muốn

Mong bác và các anh chị khác giúp sửa lỗi trên cho hoàn thiện.
Em xin cảm ơn trước
 
Lần chỉnh sửa cuối:
Upvote 0
Kính gửi bác @huuthang_bd

Code của bác đã giúp công việc của em khá tốt. Tuy nhiên có 1 lỗi rất ngớ ngẩn xuất phát từ người dùng mà em không biết cách xử lý (bẫy lỗi).

Mô tả lỗi: Nếu đặt sẵn nút lệnh ở cột O hoặc P, sau đó mới nhập dữ liệu ở dòng tương ứng. Ngay sau khi nhập liệu vừa đủ, người dùng bấm nút là Code hoạt động sai vì nó xác định ActiveCell không như mình nghĩ.
Hoặc sau khi nhập liệu xong, người dùng di chuyển nút vào vị trí để bấm, nhưng thực tế họ không bấm ngay mà cho trỏ chuột đi đâu đó. Sau đó họ lại bấm nút lệnh thì ActiveCell thực tế không còn như tính toán nữa để code chạy như mong muốn

Mong bác và các anh chị khác giúp sửa lỗi trên cho hoàn thiện.
Em xin cảm ơn trước
Mô tả lỗi
upload_2017-12-28_15-22-24.png
 
Upvote 0
Trong code của CommandButton1 thay ActiveCell bằng CommandButton1.TopLeftCell
Làm tương tự với CommandButton2
Chỉ dẫn của bác rất ngắn gọn mà rất hiệu quả. Xin cảm ơn bác.
Với CommandButton1.TopLeftCell được em hiểu là lấy địa chỉ hiện hành của nút CommandButton1. Tuy nhiên từ TopLeftCell có vẻ còn hơn ý nghĩa như vậy. Bác có thể giải thích 1 chút giúp em được không?
Chúc bác sức khỏe
 
Upvote 0
Đọc cái tên là biết nó để làm gì mà. Bạn có thể đọc thêm trong Excel Help
 
Upvote 0
Web KT
Back
Top Bottom