Nhờ viết code xuất dữ liệu ra file .txt (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

soap1234

Thành viên hoạt động
Tham gia
22/10/13
Bài viết
162
Được thích
6
Nhờ anh chị tạo em macro xuất dữ liệu ra file txt em với
em xin chân thành cảm ơn ạ
 

File đính kèm

Giải pháp
Em xin chân thành cảm ơn anh và diễn đàn đặc biệt hai anh là Maika8008, smow25 đã guip em. em muốn nhờ các anh và diễn đàn chỉnh sửa em code để lưu được nhiều file .TXT theo họ tên

Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("GCNTT17")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:AC" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\KQ\" & arr(i, 16) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, True)
             For j = 1 To UBound(arr, 2)...
Topic kia cũng cùng nội dung à bạn
 
Upvote 0
Nhờ anh chị tạo em macro xuất dữ liệu ra file txt em với
em xin chân thành cảm ơn ạ
Ở chủ đề bên kia tôi nhắc bạn chuyển mã về Unicode rồi tính tiếp. Bạn không nói không rằng gì cả, đi mở chủ đề khác. Trước đó bạn có 2 chủ đề như vậy nữa, có người nhắc về chính tả, bạn cũng im và không sửa.

Bạn có biết làm như vậy là phạm quy, thiếu tôn trọng người khác không?
 
Upvote 0
Nhờ anh chị tạo em macro xuất dữ liệu ra file txt em với
em xin chân thành cảm ơn ạ
Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Filename = ThisWorkbook.Path & "\file.txt"
    Set MyFile = fso.CreateTextFile(Filename, True, True)
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:B" & lr).Value
         For i = 1 To UBound(arr)
             MyFile.WriteLine arr(i, 1) & " " & arr(i, 2)
         Next i
    End With
         MyFile.close
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
 
Upvote 0
Dạ có gì các anh thông cảm cho em chứ em cũng lần đầu đăng bài. em có sửa Unicode rồi anh ạ nhưng không biết sao file TXT khi lưu Unicode nó vẫn lỗi anh à
 
Upvote 0
Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Filename = ThisWorkbook.Path & "\file.txt"
    Set MyFile = fso.CreateTextFile(Filename, True, True)
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:B" & lr).Value
         For i = 1 To UBound(arr)
             MyFile.WriteLine arr(i, 1) & " " & arr(i, 2)
         Next i
    End With
         MyFile.close
    Set MyFile = Nothing
    Set fso = Nothing
End Sub

Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Filename = ThisWorkbook.Path & "\file.txt"
    Set MyFile = fso.CreateTextFile(Filename, True, True)
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:B" & lr).Value
         For i = 1 To UBound(arr)
             MyFile.WriteLine arr(i, 1) & " " & arr(i, 2)
         Next i
    End With
         MyFile.close
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
EM MUỐM XUẤT FILE CẤU TRÚC ..TXTX NHƯ HÌNH VÀ ĐẶT TÊN FILE THEO HỌ TÊN ĐƯỢC KHÔNG ANH
 

File đính kèm

Upvote 0

File đính kèm

Upvote 0
EM MUỐM XUẤT FILE CẤU TRÚC ..TXTX NHƯ HÌNH VÀ ĐẶT TÊN FILE THEO HỌ TÊN ĐƯỢC KHÔNG ANH
Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("slieu")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:T" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\" & arr(i, 17) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, True)
             For j = 1 To UBound(arr, 2)
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
  
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("slieu")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:T" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\" & arr(i, 17) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, True)
             For j = 1 To UBound(arr, 2)
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
 
    Set MyFile = Nothing
    Set fso = Nothing
End Sub


 
Lần chỉnh sửa cuối:
Upvote 0
Em xin chân thành cảm ơn anh và diễn đàn đặc biệt hai anh là Maika8008, smow25 đã guip em. em muốn nhờ các anh và diễn đàn chỉnh sửa em code để lưu được nhiều file .TXT theo họ tên

Thử code.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("GCNTT17")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:AC" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\KQ\" & arr(i, 16) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, True)
             For j = 1 To UBound(arr, 2)
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
 
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
 
Upvote 0
Giải pháp
Em xin chân thành cảm ơn anh và diễn đàn đặc biệt hai anh là Maika8008, smow25 đã guip em. em muốn nhờ các anh và diễn đàn chỉnh sửa em code để lưu được nhiều file .TXT theo họ tên

Code đã lưu mỗi dòng mỗi file rồi mà bạn!
 
Upvote 0
Em xin chân thành cảm ơn anh và diễn đàn đặc biệt hai anh là Maika8008, smow25 đã guip em. em muốn nhờ các anh và diễn đàn chỉnh sửa em code để lưu được nhiều file .TXT theo họ tên

@soap1234 : File cho bạn, không cần dùng file Mau.txt như bài #9 nữa. Code bài 9 vẫn đã xuất được 2 file cho 2 dòng dữ liệu rồi ấy chứ.

@snow25 : bài #12 bạn lấy arr(i, 16) & ".txt" làm tên mà arr(i, 16) cả 2 dòng đều là Tỉnh Nghệ An nên kết quả xuất ra chỉ có 1 file thôi. (xin lỗi: tôi nhầm với dữ liệu cũ)
 

File đính kèm

Upvote 0
@snow25 : bài #12 bạn lấy arr(i, 16) & ".txt" làm tên mà arr(i, 16) cả 2 dòng đều là Tỉnh Nghệ An nên kết quả xuất ra chỉ có 1 file thôi. (xin lỗi: tôi nhầm với dữ liệu cũ)
Thực ra viết code tôi không để ý dữ liệu.Nếu mà đã tách thì thêm cái gì cho khác nhau là được.Chẳng qua là do tác giả cần thế nào thì viết thôi.Chứ cùng tên thì nó sẽ xóa cái trước là đúng rồi.
 
Upvote 0
Thực ra viết code tôi không để ý dữ liệu.Nếu mà đã tách thì thêm cái gì cho khác nhau là được.Chẳng qua là do tác giả cần thế nào thì viết thôi.Chứ cùng tên thì nó sẽ xóa cái trước là đúng rồi.
Các anh ơi code khi xuất file .txt ngon lành rồi nhưng khi em nhập file .txt vào phần mềm. phần mềm yêu cầu giữa các cột trong file.TXT là một khoảng tab như hình vẽ mới nhận dữ liệu các anh à. nếu dùng đoạn code em gửi trong file HoSoTXT thì phần mềm nhận nhưng lại chỉ lưu được 1 file anh à
giờ em muốn nhờ các anh chỉnh sửa code trong file HoSoTXT để lưu được nhiều file
hoặc các anh chỉnh sửa code của anh Maik80008 và anh smow25 với. em xin chân thành cảm ơn các anh
 

File đính kèm

  • dinh dang.jpg
    dinh dang.jpg
    16.3 KB · Đọc: 16
  • HoSoTXT.rar
    HoSoTXT.rar
    32.8 KB · Đọc: 14
Upvote 0
Các anh ơi code khi xuất file .txt ngon lành rồi nhưng khi em nhập file .txt vào phần mềm. phần mềm yêu cầu giữa các cột trong file.TXT là một khoảng tab như hình vẽ mới nhận dữ liệu các anh à. nếu dùng đoạn code em gửi trong file HoSoTXT thì phần mềm nhận nhưng lại chỉ lưu được 1 file anh à
giờ em muốn nhờ các anh chỉnh sửa code trong file HoSoTXT để lưu được nhiều file
hoặc các anh chỉnh sửa code của anh Maik80008 và anh smow25 với. em xin chân thành cảm ơn các anh
Thay: Space(18 - Len(aTitle(1, j))) bằng vbTab

hoặc code của snow25, thay Space(18 - Len(arr(1, j))) bằng vbTab
 
Upvote 0
em nạp rồi anh à bị lỗi. có cách nào viết code rồi xuất sang .TXT mà không bị lỗi không anh
Nếu không dùng bảng mã Unicode mà buộc phải là TCVN3 thì tôi chịu thua. Bạn chờ ai đó biết về việc này trả lời hoặc mở chủ đề mới hỏi riêng về việc đó xem.
 
Upvote 0
Nếu không dùng bảng mã Unicode mà buộc phải là TCVN3 thì tôi chịu thua. Bạn chờ ai đó biết về việc này trả lời hoặc mở chủ đề mới hỏi riêng về việc đó xem.
Dạ dù gì em xin cũng chân thành cảm ơn anh ạ. em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh . nếu có cho em xin với
 
Upvote 0
Dạ dù gì em xin cũng chân thành cảm ơn anh ạ. em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh . nếu có cho em xin với
Bạn dùng chức năng chuyển mã Clipboard của bộ gõ Unikey nhé.
 
Upvote 0
Cái của thớt dính ANSI nên ngỏm.
Lưu ở utf-8 là ngon lành. Unicode không liên quan gì cả
 
Upvote 0
Dạ dù gì em xin cũng chân thành cảm ơn anh ạ. em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh . nếu có cho em xin với
Chả hiểu bạn muốn gì.

Trong bài #1 bạn có TCVN3


Bây giờ bạn chuyển hết dữ liệu nguồn về unicode để rồi lại phải đi hỏi:
em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh

Sao kỳ cục vậy? Dữ liệu đầu vào của bạn là TCVN3 hay unicode? Theo như bài cũ nhất mà tôi trích link ở trên thì bạn có TCVN3. Bạn nghe lời khuyên nên chuyển về unicode. Để rồi bây giờ lại xoay xở làm sao chuyển từ unicode về TCVN3? Thế thì cứ để nguyên TCVN3 như ban đầu có phải nhẹ đầu, nhẹ người, nhẹ code, nhẹ máy, ít tốn điện nước không?
 
Upvote 0
Chả hiểu bạn muốn gì.

Trong bài #1 bạn có TCVN3


Bây giờ bạn chuyển hết dữ liệu nguồn về unicode để rồi lại phải đi hỏi:


Sao kỳ cục vậy? Dữ liệu đầu vào của bạn là TCVN3 hay unicode? Theo như bài cũ nhất mà tôi trích link ở trên thì bạn có TCVN3. Bạn nghe lời khuyên nên chuyển về unicode. Để rồi bây giờ lại xoay xở làm sao chuyển từ unicode về TCVN3? Thế thì cứ để nguyên TCVN3 như ban đầu có phải nhẹ đầu, nhẹ người, nhẹ code, nhẹ máy, ít tốn điện nước không?Da

Chả hiểu bạn muốn gì.

Trong bài #1 bạn có TCVN3


Bây giờ bạn chuyển hết dữ liệu nguồn về unicode để rồi lại phải đi hỏi:


Sao kỳ cục vậy? Dữ liệu đầu vào của bạn là TCVN3 hay unicode? Theo như bài cũ nhất mà tôi trích link ở trên thì bạn có TCVN3. Bạn nghe lời khuyên nên chuyển về unicode. Để rồi bây giờ lại xoay xở làm sao chuyển từ unicode về TCVN3? Thế thì cứ để nguyên TCVN3 như ban đầu có phải nhẹ đầu, nhẹ người, nhẹ code, nhẹ máy, ít tốn điện nước không?
Hì. Dạ anh à file Dữ liệu có hai mục đích một là xuất file. TXT để đưa vào phần mềm củ chỉ nhận font là .vntime, .vnarial . còn font time new roman, Arial là để xuất báo cáo tài liệu. Nên lằng nhằng anh à. Có gì các anh thông cảm em với
 
Upvote 0
Hì. Dạ anh à file Dữ liệu có hai mục đích một là xuất file. TXT để đưa vào phần mềm củ chỉ nhận font là .vntime, .vnarial . còn font time new roman, Arial là để xuất báo cáo tài liệu. Nên lằng nhằng anh à. Có gì các anh thông cảm em với
Bạn không phải giải thích lằng nhằng. Trong bài


rõ ràng bạn có TCVN3. Sau đó do Maika8008 yêu cầu nên trong chủ đề này bạn lại đính kèm tập tin khác với unicode. Vậy tôi có câu hỏi rất rõ ràng. Thực tế thì bạn có dữ liệu gốc là TCVN3 hay unicode?

Nếu bạn có TCVN3 rồi theo yêu cầu bạn convert sang unicode để rồi bạn lại phải xoay xở: "em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh ", thì ban đầu bạn chuyển từ TCVN3 sang unicode để làm gì?

Dữ liệu gốc là TCVN3 như chủ đề mà tôi cung cấp link hay là unicode như ở chủ đề này? Chỉ có thể là TCVN3 hoặc unicode thôi, nên đừng thử trả lời kiểu "vừa TCVN3 vừa unicode". Nếu gốc là TCVN3 thì đính kèm lại tập tin với TCVN3. Thế thôi, chả phải gải thích gì cả.
 
Upvote 0
Bạn không phải giải thích lằng nhằng. Trong bài


rõ ràng bạn có TCVN3. Sau đó do Maika8008 yêu cầu nên trong chủ đề này bạn lại đính kèm tập tin khác với unicode. Vậy tôi có câu hỏi rất rõ ràng. Thực tế thì bạn có dữ liệu gốc là TCVN3 hay unicode?

Nếu bạn có TCVN3 rồi theo yêu cầu bạn convert sang unicode để rồi bạn lại phải xoay xở: "em nghĩ rồi giờ mình chuyển font tren file excel sang .vntime rồi mới xuất anh à. không biết anh có code chuyển UNicos sang tcvn3 trên file excel không anh ", thì ban đầu bạn chuyển từ TCVN3 sang unicode để làm gì?

Dữ liệu gốc là TCVN3 như chủ đề mà tôi cung cấp link hay là unicode như ở chủ đề này? Chỉ có thể là TCVN3 hoặc unicode thôi, nên đừng thử trả lời kiểu "vừa TCVN3 vừa unicode". Nếu gốc là TCVN3 thì đính kèm lại tập tin với TCVN3. Thế thôi, chả phải gải thích gì cả.
Dữ liệu file là unicode trong chủ đề này anh à. anh có code nào chỉ giáo em với .
 
Upvote 0
Dữ liệu file là unicode trong chủ đề này anh à. anh có code nào chỉ giáo em với .
Tôi tưởng dữ liệu gốc đã có rồi, đã được gõ, được nhập rồi. Và nó chỉ có thể là TCVN3 hoặc unicode. Không thể là mấy hôm trước cũng dữ liệu đó nó là TCVN3, hôm nay mở ra nó lại là unicode. Bạn chỉ có thể muốn 2 code, một cho TCVN3 một cho unicode là gốc.

Nếu là TCVN3 như ở "bên kia" thì cứ trích lọc nó ra thôi. Còn nếu là unicode thì phải chuyển lại thành TCVN3. Chả có cách bí mật nào khác.
 
Upvote 0
Dạ chuẩn luôn anh à. anh có code nào không anh em loay hoay mãi anh à
Thử code này xem có được không.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("GCNTT17")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:AC" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\KQ\" & arr(i, 16) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, False)
             For j = 1 To UBound(arr, 2)
                If IsUnicode(arr(1, j)) Then
                   arr(1, j) = UnitoTCVN(arr(1, j))
                End If
                If IsUnicode(arr(i, j)) Then
                   arr(i, j) = UnitoTCVN(arr(i, j))
                End If
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
 
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
Function UnitoTCVN(vnStr) As String
On Error Resume Next
   Dim sTemp$
   Dim c As String, i As Integer, L As Long, iC As Long
   For i = 1 To Len(vnStr)
      c = Mid(vnStr, i, 1)
      Select Case c
            Case ChrW$(272): c = ChrW$(167)
            Case ChrW$(259): c = ChrW$(168)
            Case ChrW$(226): c = ChrW$(169)
            Case ChrW$(234): c = ChrW$(170)
            Case ChrW$(244): c = ChrW$(171)
            Case ChrW$(417): c = ChrW$(172)
            Case ChrW$(432): c = ChrW$(173)
            Case ChrW$(273): c = ChrW$(174)
            Case ChrW$(224): c = ChrW$(181)
            Case ChrW$(7843): c = ChrW$(182)
            Case ChrW$(227): c = ChrW$(183)
            Case ChrW$(225): c = ChrW$(184)
            Case ChrW$(7841): c = ChrW$(185)
            Case ChrW$(7857): c = ChrW$(187)
            Case ChrW$(7859): c = ChrW$(188)
            Case ChrW$(7861): c = ChrW$(189)
            Case ChrW$(7855): c = ChrW$(190)
            Case ChrW$(7863): c = ChrW$(198)
            Case ChrW$(7847): c = ChrW$(199)
            Case ChrW$(7849): c = ChrW$(200)
            Case ChrW$(7851): c = ChrW$(201)
            Case ChrW$(7845): c = ChrW$(202)
            Case ChrW$(7853): c = ChrW$(203)
            Case ChrW$(232): c = ChrW$(204)
            Case ChrW$(7867): c = ChrW$(206)
            Case ChrW$(7869): c = ChrW$(207)
            Case ChrW$(233): c = ChrW$(208)
            Case ChrW$(7865): c = ChrW$(209)
            Case ChrW$(7873): c = ChrW$(210)
            Case ChrW$(7875): c = ChrW$(211)
            Case ChrW$(7877): c = ChrW$(212)
            Case ChrW$(7871): c = ChrW$(213)
            Case ChrW$(7879): c = ChrW$(214)
            Case ChrW$(236): c = ChrW$(215)
            Case ChrW$(7881): c = ChrW$(216)
            Case ChrW$(297): c = ChrW$(220)
            Case ChrW$(237): c = ChrW$(221)
            Case ChrW$(7883): c = ChrW$(222)
            Case ChrW$(242): c = ChrW$(223)
            Case ChrW$(7887): c = ChrW$(225)
            Case ChrW$(245): c = ChrW$(226)
            Case ChrW$(243): c = ChrW$(227)
            Case ChrW$(7885): c = ChrW$(228)
            Case ChrW$(7891): c = ChrW$(229)
            Case ChrW$(7893): c = ChrW$(230)
            Case ChrW$(7895): c = ChrW$(231)
            Case ChrW$(7889): c = ChrW$(232)
            Case ChrW$(7897): c = ChrW$(233)
            Case ChrW$(7901): c = ChrW$(234)
            Case ChrW$(7903): c = ChrW$(235)
            Case ChrW$(7905): c = ChrW$(236)
            Case ChrW$(7899): c = ChrW$(237)
            Case ChrW$(7907): c = ChrW$(238)
            Case ChrW$(249): c = ChrW$(239)
            Case ChrW$(7911): c = ChrW$(241)
            Case ChrW$(361): c = ChrW$(242)
            Case ChrW$(250): c = ChrW$(243)
            Case ChrW$(7909): c = ChrW$(244)
            Case ChrW$(7915): c = ChrW$(245)
            Case ChrW$(7917): c = ChrW$(246)
            Case ChrW$(7919): c = ChrW$(247)
            Case ChrW$(7913): c = ChrW$(248)
            Case ChrW$(7921): c = ChrW$(249)
            Case ChrW$(7923): c = ChrW$(250)
            Case ChrW$(7927): c = ChrW$(251)
            Case ChrW$(7929): c = ChrW$(252)
            Case ChrW$(253): c = ChrW$(253)
            Case ChrW$(7925): c = ChrW$(254)
            '----------------------------------------
            Case ChrW$(192): c = ChrW$(181)
            Case ChrW$(193): c = ChrW$(184)
            Case ChrW$(195): c = ChrW$(183)
            Case ChrW$(194): c = ChrW$(162)
            Case ChrW$(201): c = ChrW$(208)
            Case ChrW$(200): c = ChrW$(204)
            Case ChrW$(202): c = ChrW$(163)
            Case ChrW$(7878): c = ChrW$(214)
            Case ChrW$(204): c = ChrW$(215)
            Case ChrW$(211): c = ChrW$(227)
            Case ChrW$(210): c = ChrW$(223)
            Case ChrW$(212): c = ChrW$(164)
            Case ChrW$(213): c = ChrW$(226)
            Case ChrW$(218): c = ChrW$(243)
            Case ChrW$(221): c = ChrW$(253)
      End Select
      sTemp = sTemp + c
   Next i
   UnitoTCVN = sTemp
End Function
'Xac dinh co phai la Unicode hay khong (Suu tam)?
Function IsUnicode(StrRange As Variant) As Boolean
   Dim Str As String, i As Long, bLen As Long, Map() As Byte
   Str = StrRange
   If LenB(Str) Then
      Map = Str
      bLen = UBound(Map)
      For i = 1 To bLen Step 2
         If (Map(i) > 0) Then
            IsUnicode = True
            Exit Function
         End If
      Next
   End If
End Function
 
Upvote 0
Khi xuất ra file. TXT vẫn lỗi chữ anh à
em có gán đoạn code sau
Thử code này xem có được không.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("GCNTT17")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:AC" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\KQ\" & arr(i, 16) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, False)
             For j = 1 To UBound(arr, 2)
                If IsUnicode(arr(1, j)) Then
                   arr(1, j) = UnitoTCVN(arr(1, j))
                End If
                If IsUnicode(arr(i, j)) Then
                   arr(i, j) = UnitoTCVN(arr(i, j))
                End If
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
 
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
Function UnitoTCVN(vnStr) As String
On Error Resume Next
   Dim sTemp$
   Dim c As String, i As Integer, L As Long, iC As Long
   For i = 1 To Len(vnStr)
      c = Mid(vnStr, i, 1)
      Select Case c
            Case ChrW$(272): c = ChrW$(167)
            Case ChrW$(259): c = ChrW$(168)
            Case ChrW$(226): c = ChrW$(169)
            Case ChrW$(234): c = ChrW$(170)
            Case ChrW$(244): c = ChrW$(171)
            Case ChrW$(417): c = ChrW$(172)
            Case ChrW$(432): c = ChrW$(173)
            Case ChrW$(273): c = ChrW$(174)
            Case ChrW$(224): c = ChrW$(181)
            Case ChrW$(7843): c = ChrW$(182)
            Case ChrW$(227): c = ChrW$(183)
            Case ChrW$(225): c = ChrW$(184)
            Case ChrW$(7841): c = ChrW$(185)
            Case ChrW$(7857): c = ChrW$(187)
            Case ChrW$(7859): c = ChrW$(188)
            Case ChrW$(7861): c = ChrW$(189)
            Case ChrW$(7855): c = ChrW$(190)
            Case ChrW$(7863): c = ChrW$(198)
            Case ChrW$(7847): c = ChrW$(199)
            Case ChrW$(7849): c = ChrW$(200)
            Case ChrW$(7851): c = ChrW$(201)
            Case ChrW$(7845): c = ChrW$(202)
            Case ChrW$(7853): c = ChrW$(203)
            Case ChrW$(232): c = ChrW$(204)
            Case ChrW$(7867): c = ChrW$(206)
            Case ChrW$(7869): c = ChrW$(207)
            Case ChrW$(233): c = ChrW$(208)
            Case ChrW$(7865): c = ChrW$(209)
            Case ChrW$(7873): c = ChrW$(210)
            Case ChrW$(7875): c = ChrW$(211)
            Case ChrW$(7877): c = ChrW$(212)
            Case ChrW$(7871): c = ChrW$(213)
            Case ChrW$(7879): c = ChrW$(214)
            Case ChrW$(236): c = ChrW$(215)
            Case ChrW$(7881): c = ChrW$(216)
            Case ChrW$(297): c = ChrW$(220)
            Case ChrW$(237): c = ChrW$(221)
            Case ChrW$(7883): c = ChrW$(222)
            Case ChrW$(242): c = ChrW$(223)
            Case ChrW$(7887): c = ChrW$(225)
            Case ChrW$(245): c = ChrW$(226)
            Case ChrW$(243): c = ChrW$(227)
            Case ChrW$(7885): c = ChrW$(228)
            Case ChrW$(7891): c = ChrW$(229)
            Case ChrW$(7893): c = ChrW$(230)
            Case ChrW$(7895): c = ChrW$(231)
            Case ChrW$(7889): c = ChrW$(232)
            Case ChrW$(7897): c = ChrW$(233)
            Case ChrW$(7901): c = ChrW$(234)
            Case ChrW$(7903): c = ChrW$(235)
            Case ChrW$(7905): c = ChrW$(236)
            Case ChrW$(7899): c = ChrW$(237)
            Case ChrW$(7907): c = ChrW$(238)
            Case ChrW$(249): c = ChrW$(239)
            Case ChrW$(7911): c = ChrW$(241)
            Case ChrW$(361): c = ChrW$(242)
            Case ChrW$(250): c = ChrW$(243)
            Case ChrW$(7909): c = ChrW$(244)
            Case ChrW$(7915): c = ChrW$(245)
            Case ChrW$(7917): c = ChrW$(246)
            Case ChrW$(7919): c = ChrW$(247)
            Case ChrW$(7913): c = ChrW$(248)
            Case ChrW$(7921): c = ChrW$(249)
            Case ChrW$(7923): c = ChrW$(250)
            Case ChrW$(7927): c = ChrW$(251)
            Case ChrW$(7929): c = ChrW$(252)
            Case ChrW$(253): c = ChrW$(253)
            Case ChrW$(7925): c = ChrW$(254)
            '----------------------------------------
            Case ChrW$(192): c = ChrW$(181)
            Case ChrW$(193): c = ChrW$(184)
            Case ChrW$(195): c = ChrW$(183)
            Case ChrW$(194): c = ChrW$(162)
            Case ChrW$(201): c = ChrW$(208)
            Case ChrW$(200): c = ChrW$(204)
            Case ChrW$(202): c = ChrW$(163)
            Case ChrW$(7878): c = ChrW$(214)
            Case ChrW$(204): c = ChrW$(215)
            Case ChrW$(211): c = ChrW$(227)
            Case ChrW$(210): c = ChrW$(223)
            Case ChrW$(212): c = ChrW$(164)
            Case ChrW$(213): c = ChrW$(226)
            Case ChrW$(218): c = ChrW$(243)
            Case ChrW$(221): c = ChrW$(253)
      End Select
      sTemp = sTemp + c
   Next i
   UnitoTCVN = sTemp
End Function
'Xac dinh co phai la Unicode hay khong (Suu tam)?
Function IsUnicode(StrRange As Variant) As Boolean
   Dim Str As String, i As Long, bLen As Long, Map() As Byte
   Str = StrRange
   If LenB(Str) Then
      Map = Str
      bLen = UBound(Map)
      For i = 1 To bLen Step 2
         If (Map(i) > 0) Then
            IsUnicode = True
            Exit Function
         End If
      Next
   End If
End Function
Dạ em làm theo anh vẫn lỗi Font khi xuất ra TXTanh à.
Thử code này xem có được không.
Mã:
Sub tach()
    Dim i As Long, lr As Long, arr, fso As Object, Filename As String, MyFile As Object, j As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Sheets("GCNTT17")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A1:AC" & lr).Value
         For i = 2 To UBound(arr)
             Filename = ThisWorkbook.Path & "\KQ\" & arr(i, 16) & ".txt"
             Set MyFile = fso.CreateTextFile(Filename, True, False)
             For j = 1 To UBound(arr, 2)
                If IsUnicode(arr(1, j)) Then
                   arr(1, j) = UnitoTCVN(arr(1, j))
                End If
                If IsUnicode(arr(i, j)) Then
                   arr(i, j) = UnitoTCVN(arr(i, j))
                End If
                 MyFile.WriteLine arr(1, j) & Space(18 - Len(arr(1, j))) & Application.Trim(arr(i, j))
             Next j
               MyFile.Close
         Next i
    End With
 
    Set MyFile = Nothing
    Set fso = Nothing
End Sub
Function UnitoTCVN(vnStr) As String
On Error Resume Next
   Dim sTemp$
   Dim c As String, i As Integer, L As Long, iC As Long
   For i = 1 To Len(vnStr)
      c = Mid(vnStr, i, 1)
      Select Case c
            Case ChrW$(272): c = ChrW$(167)
            Case ChrW$(259): c = ChrW$(168)
            Case ChrW$(226): c = ChrW$(169)
            Case ChrW$(234): c = ChrW$(170)
            Case ChrW$(244): c = ChrW$(171)
            Case ChrW$(417): c = ChrW$(172)
            Case ChrW$(432): c = ChrW$(173)
            Case ChrW$(273): c = ChrW$(174)
            Case ChrW$(224): c = ChrW$(181)
            Case ChrW$(7843): c = ChrW$(182)
            Case ChrW$(227): c = ChrW$(183)
            Case ChrW$(225): c = ChrW$(184)
            Case ChrW$(7841): c = ChrW$(185)
            Case ChrW$(7857): c = ChrW$(187)
            Case ChrW$(7859): c = ChrW$(188)
            Case ChrW$(7861): c = ChrW$(189)
            Case ChrW$(7855): c = ChrW$(190)
            Case ChrW$(7863): c = ChrW$(198)
            Case ChrW$(7847): c = ChrW$(199)
            Case ChrW$(7849): c = ChrW$(200)
            Case ChrW$(7851): c = ChrW$(201)
            Case ChrW$(7845): c = ChrW$(202)
            Case ChrW$(7853): c = ChrW$(203)
            Case ChrW$(232): c = ChrW$(204)
            Case ChrW$(7867): c = ChrW$(206)
            Case ChrW$(7869): c = ChrW$(207)
            Case ChrW$(233): c = ChrW$(208)
            Case ChrW$(7865): c = ChrW$(209)
            Case ChrW$(7873): c = ChrW$(210)
            Case ChrW$(7875): c = ChrW$(211)
            Case ChrW$(7877): c = ChrW$(212)
            Case ChrW$(7871): c = ChrW$(213)
            Case ChrW$(7879): c = ChrW$(214)
            Case ChrW$(236): c = ChrW$(215)
            Case ChrW$(7881): c = ChrW$(216)
            Case ChrW$(297): c = ChrW$(220)
            Case ChrW$(237): c = ChrW$(221)
            Case ChrW$(7883): c = ChrW$(222)
            Case ChrW$(242): c = ChrW$(223)
            Case ChrW$(7887): c = ChrW$(225)
            Case ChrW$(245): c = ChrW$(226)
            Case ChrW$(243): c = ChrW$(227)
            Case ChrW$(7885): c = ChrW$(228)
            Case ChrW$(7891): c = ChrW$(229)
            Case ChrW$(7893): c = ChrW$(230)
            Case ChrW$(7895): c = ChrW$(231)
            Case ChrW$(7889): c = ChrW$(232)
            Case ChrW$(7897): c = ChrW$(233)
            Case ChrW$(7901): c = ChrW$(234)
            Case ChrW$(7903): c = ChrW$(235)
            Case ChrW$(7905): c = ChrW$(236)
            Case ChrW$(7899): c = ChrW$(237)
            Case ChrW$(7907): c = ChrW$(238)
            Case ChrW$(249): c = ChrW$(239)
            Case ChrW$(7911): c = ChrW$(241)
            Case ChrW$(361): c = ChrW$(242)
            Case ChrW$(250): c = ChrW$(243)
            Case ChrW$(7909): c = ChrW$(244)
            Case ChrW$(7915): c = ChrW$(245)
            Case ChrW$(7917): c = ChrW$(246)
            Case ChrW$(7919): c = ChrW$(247)
            Case ChrW$(7913): c = ChrW$(248)
            Case ChrW$(7921): c = ChrW$(249)
            Case ChrW$(7923): c = ChrW$(250)
            Case ChrW$(7927): c = ChrW$(251)
            Case ChrW$(7929): c = ChrW$(252)
            Case ChrW$(253): c = ChrW$(253)
            Case ChrW$(7925): c = ChrW$(254)
            '----------------------------------------
            Case ChrW$(192): c = ChrW$(181)
            Case ChrW$(193): c = ChrW$(184)
            Case ChrW$(195): c = ChrW$(183)
            Case ChrW$(194): c = ChrW$(162)
            Case ChrW$(201): c = ChrW$(208)
            Case ChrW$(200): c = ChrW$(204)
            Case ChrW$(202): c = ChrW$(163)
            Case ChrW$(7878): c = ChrW$(214)
            Case ChrW$(204): c = ChrW$(215)
            Case ChrW$(211): c = ChrW$(227)
            Case ChrW$(210): c = ChrW$(223)
            Case ChrW$(212): c = ChrW$(164)
            Case ChrW$(213): c = ChrW$(226)
            Case ChrW$(218): c = ChrW$(243)
            Case ChrW$(221): c = ChrW$(253)
      End Select
      sTemp = sTemp + c
   Next i
   UnitoTCVN = sTemp
End Function
'Xac dinh co phai la Unicode hay khong (Suu tam)?
Function IsUnicode(StrRange As Variant) As Boolean
   Dim Str As String, i As Long, bLen As Long, Map() As Byte
   Str = StrRange
   If LenB(Str) Then
      Map = Str
      bLen = UBound(Map)
      For i = 1 To bLen Step 2
         If (Map(i) > 0) Then
            IsUnicode = True
            Exit Function
         End If
      Next
   End If
End Function
Dạ em làm theo code của anh mà vẫn lỗi Font anh à
em có code tìm trên diễn đàn mà không biết sao cứ báo lỗi anh à
nhờ anh xem giúp em với. em cảm ơn anh nhiều.
 

File đính kèm

Upvote 0
Khi xuất ra file. TXT vẫn lỗi chữ anh à
Bạn có vẻ không muốn trả lời tôi nữa nhỉ. Tôi chỉ muốn chắc chắn là vài ngày nữa bạn sẽ không đổi ý. Còn nếu cứ muốn dữ liệu gốc là unicode thì thễ này.

Bạn có dữ liệu gốc dạng unicode. Bạn muốn trích từ đó một số dữ lệu và ghi vào tập tin trên đĩa. Mục đích là để nhập vào phần mềm. Nhưng phần mềm lại chỉ chấp nhận TCVN3, đúng không?

Bạn hãy kiểm tra 3 tập tin txt đính kèm xem có nhập được vào phần mềm không. Nếu không thì tôi dừng ở đây. Nếu phần mềm chấp nhận 3 tập tin txt thì tôi sẽ cho bạn code.
 
Lần chỉnh sửa cuối:
Upvote 0
Khi xuất ra file. TXT vẫn lỗi chữ anh à
em có gán đoạn code sau

Dạ em làm theo anh vẫn lỗi Font khi xuất ra TXTanh à.

Dạ em làm theo code của anh mà vẫn lỗi Font anh à
em có code tìm trên diễn đàn mà không biết sao cứ báo lỗi anh à
nhờ anh xem giúp em với. em cảm ơn anh nhiều.
Bạn không đọc được nhưng khi up vào phần mềm nó có lỗi không.
 
Upvote 0
Khi xuất ra file. TXT vẫn lỗi chữ anh à
em có gán đoạn code sau

Dạ em làm theo anh vẫn lỗi Font khi xuất ra TXTanh à.

Dạ em làm theo code của anh mà vẫn lỗi Font anh à
em có code tìm trên diễn đàn mà không biết sao cứ báo lỗi anh à
nhờ anh xem giúp em với. em cảm ơn anh nhiều.
Đây bạn xem nhé chỉnh lại 1 chút.
 

File đính kèm

Upvote 0
Đây bạn xem nhé chỉnh lại 1 chút.

Đây bạn xem nhé chỉnh lại 1 chút.
Thật là vi diệu anh snow25 cảm ơn anh rất rất nhiều. anh nhắn tin số điện thoại của anh để em cảm ơn anh bằng cái thẻ điện thoại không anh
Anh có thể sửa code chọn theo dòng ô như hình vẽ không anh. vì nhiều lúc muốn xuất 1 thửa bất kỳ chứ không xuất cả anh à

 

File đính kèm

  • theo dong.jpg
    theo dong.jpg
    16.1 KB · Đọc: 7
Upvote 0
Thật là vi diệu anh snow25 cảm ơn anh rất rất nhiều. anh nhắn tin số điện thoại của anh để em cảm ơn anh bằng cái thẻ điện thoại không anh
Anh có thể sửa code chọn theo dòng ô như hình vẽ không anh. vì nhiều lúc muốn xuất 1 thửa bất kỳ chứ không xuất cả anh à

Bạn thử cái này nhé.Nếu bạn hỗ trợ thì có Momo mình đính kèm.
 

File đính kèm

Upvote 0

Bài viết mới nhất

Back
Top Bottom