Xin code giúp ghi file excel ra file TXT mẫu

sanhdieu0911 · 9/7/17

Mọi người cho tôi xin code ghi file Excel ban đầu, ra dạng file Ketqua.TXT với. Cám ơn mọi người đã quan tâm.

Mutants Men · 9/7/17

sanhdieu0911 đã viết:
Mọi người cho tôi xin code ghi file Excel ban đầu, ra dạng file Ketqua.TXT với. Cám ơn mọi người đã quan tâm.

làm thì được đấy bạn, nhưng bạn cho hỏi có quy luật gì không.
hay muốn ra y chang xì lì vậy?
_ _ 167772165, "P2", , , ,"", 06-07-2017/09:40:28.0 , MEAS; (dòng 1 file txt)
chỗ màu đỏ là 2 dấu Tab. vì sao lại có 2 dấu tab ở đó. trong file excel con số này 167772165 ngay cột A
_ _ _ 167772171, "2", "Info 1", ""; (dòng 24 file txt)
167772171 con số này trong file excel cũng ở cột A, vì sao trước nó lại có 3 dấu Tab
dòng 57 cũng thế cũng chỉ là 2 dấu tab
Dòng trống. theo file excel thì là dòng 1 và dòng 23 có dòng trống
còn file txt thì lại là 22 và 23
sao lại ra như thế. mắc công làm y xì lì rồi sau này sửa tới lui mắc công
bạn hướng dẫn mấy cái trên thì tôi chắc có thể viết giùm bạn code, còn không chắc chỉ cung cấp code cho bạn, rồi tự xử thôi

Mã:

Sub TaoFile(ByVal DuongDan As String, ByVal NoiDung As String)
    'CHU THICH LENH: TAO FILE TXT VA VIET NOI DUNG VAO FILE
    Dim Arr As Variant
    Dim MyFile As Object
    Dim fso As Object
    Dim i As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Arr = Split(DuongDan, "\")
    DuongDan = Arr(0)
    For i = LBound(Arr) + 1 To UBound(Arr) - 1
        DuongDan = DuongDan & "\" & Arr(i)
        If Not fso.FolderExists(DuongDan) Then
            fso.CreateFolder (DuongDan)
        End If
    Next i
    If Right(Arr(i), 4) <> ".txt" Then Arr(i) = Arr(i) & ".txt"
    DuongDan = DuongDan & "\" & Arr(i)
    On Error Resume Next
    fso.DeleteFile (DuongDan)
    Set MyFile = fso.CreateTextFile(DuongDan, True, True)
    With MyFile
        .WriteLine NoiDung
        .Close
    End With
    Set MyFile = Nothing
    Set fso = Nothing
End Sub

DuongDan: đường dẫn file cần tạo, ví dụ D:\FileText.txt
NoiDung: nội dung điền vào file theo đường dẫn

sanhdieu0911 · 9/7/17

Cám ơn bạn đã quan tâm, mình đã sửa lại _ _ 167772171, "2", "Info 1", ""; (dòng 24 file txt) : tôi đã đẩy toàn bộ số liệu đó sang cột B
Dòng trống. theo file excel thì là dòng 1 và dòng 23 có dòng trống, còn file txt thì lại là 22 và 23 : Cái này mình rất xin lỗi, do mình không để ý, thực ra chỉ quan trọng dòng trống trong file excel để ngăn cách các dữ liệu. mình đã xóa dòng trống ở 1 trong excel và 22 ở TXT rồi.
Bạn hướng dẫn mình cách chạy code đó với... mình chạy thử mãi chẳng được... Cám ơn bạn nhiều nhé.

Mutants Men · 9/7/17

sanhdieu0911 đã viết:
Cám ơn bạn đã quan tâm, mình đã sửa lại _ _ 167772171, "2", "Info 1", ""; (dòng 24 file txt) : tôi đã đẩy toàn bộ số liệu đó sang cột B
Dòng trống. theo file excel thì là dòng 1 và dòng 23 có dòng trống, còn file txt thì lại là 22 và 23 : Cái này mình rất xin lỗi, do mình không để ý, thực ra chỉ quan trọng dòng trống trong file excel để ngăn cách các dữ liệu. mình đã xóa dòng trống ở 1 trong excel và 22 ở TXT rồi.

167772165, "P2",XXX , , ,"", 06-07-2017/09:40:28.0 , MEAS; (Dòng 1)
chỗ màu xanh đó là số 0 bạn không muốn lấy đúng không?
chỗ màu đỏ là ô trống như 2 ô trước, vậy tại sao 2 ô trước không có gì, ô sau lại là ""
167772171, "2", "Info 1", ""; (<=Dòng 23 chỗ này số 1 sao trở thành "")
167772165, "P2", 1, 63.232130, 94.370520, 0.000000, 0.000000, 06-07-2017/09:40:28.0, 0.000000, 103, 00001100; dòng 56 2 chỗ đó số 0.000000 sao lại lấy mà bên trên dòng 1 lại không lấy
chỗ xanh lá đều là số sao có cái lại ở trong ngoặc kép, cái lại không. có quy luật gì không bạn

sanhdieu0911 · 9/7/17

Mutants Men đã viết:
167772165, "P2",XXX , , ,"", 06-07-2017/09:40:28.0 , MEAS; (Dòng 1)
chỗ màu xanh đó là số 0 bạn không muốn lấy đúng không?
chỗ màu đỏ là ô trống như 2 ô trước, vậy tại sao 2 ô trước không có gì, ô sau lại là ""
167772171, "2", "Info 1", ""; (<=Dòng 23 chỗ này số 1 sao trở thành "")
167772165, "P2", 1, 63.232130, 94.370520, 0.000000, 0.000000, 06-07-2017/09:40:28.0, 0.000000, 103, 00001100; dòng 56 2 chỗ đó số 0.000000 sao lại lấy mà bên trên dòng 1 lại không lấy
chỗ xanh lá đều là số sao có cái lại ở trong ngoặc kép, cái lại không. có quy luật gì không bạn

Cám ơn bạn nhé, tôi đã bỏ số 0 đi rồi vì không muốn lấy. rồi tôi đã gộp infor lại rồi. thực ra dòng infor sẽ có quy luật từ 1 đến 8 thôi nếu gộp dòng 1 đến 8 vào info thì sẽ được dòng info 1, info 2... info 8 rồi lặp lại.
Số xanh lá thì chỗ số đầu là số, còn số thứ 2 có thể là ký tự bất kỳ bạn à. bạn xem có chỗ nào bất hợp lý, bạn giúp mình thay đổi cho hợp lý với nhé.
tôi đã sửa lại file excel, có gì bạn xem giúp nhé...
Bạn giúp tôi điền sẵn đường link vào nhé D:\Ketqua.TXT luôn nhé vì tôi thử thay vào toàn bị lỗi thôi. Tôi cũng chưa hiểu phần nội dung là gì... và sửa như nào nữa.
cám ơn bạn nhiều

Mutants Men · 9/7/17

sanhdieu0911 đã viết:
Cám ơn bạn nhé, tôi đã bỏ số 0 đi rồi vì không muốn lấy. rồi tôi đã gộp infor lại rồi. thực ra dòng infor sẽ có quy luật từ 1 đến 8 thôi nếu gộp dòng 1 đến 8 vào info thì sẽ được dòng info 1, info 2... info 8 rồi lặp lại.
Số xanh lá thì chỗ số đầu là số, còn số thứ 2 có thể là ký tự bất kỳ bạn à. bạn xem có chỗ nào bất hợp lý, bạn giúp mình thay đổi cho hợp lý với nhé.
tôi đã sửa lại file excel, có gì bạn xem giúp nhé...
Bạn giúp tôi điền sẵn đường link vào nhé D:\Ketqua.TXT luôn nhé vì tôi thử thay vào toàn bị lỗi thôi. Tôi cũng chưa hiểu phần nội dung là gì... và sửa như nào nữa.
cám ơn bạn nhiều

Mã:

Sub GPE()
    Dim ArrNguon As Variant
    Dim ArrKQ As Variant
    Dim YN As Boolean
    ArrNguon = Range("A1:J16").Value
    ReDim ArrKQ(1 To UBound(ArrNguon, 1), 1 To 1)
    For i = LBound(ArrKQ, 1) To UBound(ArrNguon, 1)
        For j = LBound(ArrKQ, 2) To UBound(ArrNguon, 2)
            If Len(ArrNguon(i, j)) > 0 Then x = j
        Next j
        If x = 0 Then
            ArrKQ(i, 1) = ""
            GoTo NexX
        End If
        For j = LBound(ArrKQ, 2) To UBound(ArrNguon, 2)
            If InStr(ArrNguon(i, j), "/") > 0 Then
                ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & Replace(ArrNguon(i, j), "/", "-")
                If j < UBound(ArrNguon, 2) Then
                    j = j + 1
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "/" & ArrNguon(i, j)
                End If
                GoTo NextJ
            End If
            If Not IsNumeric(ArrNguon(i, j)) Then ArrNguon(i, j) = """" & ArrNguon(i, j) & """"
            If Len(ArrNguon(i, j)) > 0 Then
                k = k + 1
                Select Case k
                Case 1
                    ArrKQ(i, 1) = ArrKQ(i, 1) & vbTab & ArrNguon(i, j)    'cot 1
                Case 2
                    If IsNumeric(ArrNguon(i, j)) Then ArrNguon(i, j) = """" & ArrNguon(i, j) & """"    'cot 2
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)
                Case Else
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)    'cot con lai
                End Select
            Else
                If Len(ArrKQ(i, 1)) > 0 Then
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)
                Else
                    ArrKQ(i, 1) = ArrKQ(i, 1) & vbTab
                End If
            End If
            If j = x Then
                ArrKQ(i, 1) = ArrKQ(i, 1) & ";"
                Exit For
            End If
NextJ:
        Next j
NexX:
        x = 0
        k = 0
    Next i
    For i = LBound(ArrKQ, 1) To UBound(ArrKQ, 1)
        txt = txt & ArrKQ(i, 1) & ChrW(10)
    Next i
TaoFile "D:\KetQua.txt", txt
End Sub
Sub TaoFile(ByVal DuongDan As String, ByVal NoiDung As String)
   'CHU THICH LENH: TAO FILE TXT VA VIET NOI DUNG VAO FILE
   Dim Arr As Variant
   Dim MyFile As Object
   Dim fso As Object
   Dim i As Long
   Set fso = CreateObject("Scripting.FileSystemObject")
   Arr = Split(DuongDan, "\")
   DuongDan = Arr(0)
   For i = LBound(Arr) + 1 To UBound(Arr) - 1
       DuongDan = DuongDan & "\" & Arr(i)
       If Not fso.FolderExists(DuongDan) Then
           fso.CreateFolder (DuongDan)
       End If
   Next i
   If Right(Arr(i), 4) <> ".txt" Then Arr(i) = Arr(i) & ".txt"
   DuongDan = DuongDan & "\" & Arr(i)
   On Error Resume Next
   fso.DeleteFile (DuongDan)
   Set MyFile = fso.CreateTextFile(DuongDan, True, True)
   With MyFile
       .WriteLine NoiDung
       .Close
   End With
   Set MyFile = Nothing
   Set fso = Nothing
End Sub

thấy dữ liệu của bạn giống như xuất tọa độ cho máy toàn đạc nhỉ (thiết kế mà dùng số ma thì cẩn thận nha bạn)
nếu đúng vậy thì file xuất ra có thể máy không đọc được đâu.
chỗ này
ArrNguon = Range("A1:J16").Value
bạn sửa lại thành vùng dữ liệu của bạn.

sanhdieu0911 · 9/7/17

Cám ơn bạn nhiều lắm... tôi đã chạy thử và ra được file kết quả. nhưng kết quả xuất ra có chút trục trắc... các dòng được ghi liền kề và không được xuống dòng bạn à."P2", , , ,"", code đang chạy ra các dấu tab, nhưng file mẫu là dấu cách và thiếu :
167772165, "P2", , , ,"", 06-07-2017/09:40:28.0 , MEAS;
167772165, "P2", , , , , "07-06-2017", "9:40:22.0", "MEAS";
. bạn xem giúp mình với.. Đúng là file I.D.X đó bạn à. Chắc bạn cũng làm việc với file này rồi à?

lythanh1505 · 10/7/17

Mình thử chạy, mà toàn thấy lỗi.

Mutants Men · 10/7/17

sanhdieu0911 đã viết:
Cám ơn bạn nhiều lắm... tôi đã chạy thử và ra được file kết quả. nhưng kết quả xuất ra có chút trục trắc... các dòng được ghi liền kề và không được xuống dòng bạn à."P2", , , ,"", code đang chạy ra các dấu tab, nhưng file mẫu là dấu cách và thiếu :
167772165, "P2", , , ,"", 06-07-2017/09:40:28.0 , MEAS;
167772165, "P2", , , , , "07-06-2017", "9:40:22.0", "MEAS";
. bạn xem giúp mình với.. Đúng là file I.D.X đó bạn à. Chắc bạn cũng làm việc với file này rồi à?

thử code này nhé bạn

Mã:

Option Explicit
Function GPE(ByVal Rn As Range) As String
    Dim ArrNguon As Variant
    Dim ArrKQ As Variant
    Dim i As Long, j As Long, x As Long, k As Byte
    Dim txt As String
    ArrNguon = Rn.Value
    ReDim ArrKQ(1 To UBound(ArrNguon, 1), 1 To 1)
    For i = LBound(ArrKQ, 1) To UBound(ArrNguon, 1)
        For j = LBound(ArrKQ, 2) To UBound(ArrNguon, 2)
            If Len(ArrNguon(i, j)) > 0 Then x = j
        Next j
        If x = 0 Then
            ArrKQ(i, 1) = ""
            GoTo NexX
        End If
        For j = LBound(ArrKQ, 2) To UBound(ArrNguon, 2)
            If InStr(ArrNguon(i, j), "/") > 0 Or InStr(ArrNguon(i, j), "-") > 0 Then
                ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & Replace(ArrNguon(i, j), "/", "-")
                If j < UBound(ArrNguon, 2) Then
                    j = j + 1
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "/" & ArrNguon(i, j)
                End If
                GoTo NextJ
            End If
            If Not IsNumeric(ArrNguon(i, j)) Then ArrNguon(i, j) = """" & ArrNguon(i, j) & """"
            If Len(ArrNguon(i, j)) > 0 Then
                k = k + 1
                Select Case k
                Case 1
                    ArrKQ(i, 1) = ArrKQ(i, 1) & vbTab & ArrNguon(i, j)    'cot 1
                Case 2
                    If IsNumeric(ArrNguon(i, j)) Then ArrNguon(i, j) = """" & ArrNguon(i, j) & """"    'cot 2
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)
                Case Else
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)    'cot con lai
                End Select
            Else
                If Len(ArrKQ(i, 1)) > 0 Then
                    ArrKQ(i, 1) = ArrKQ(i, 1) & "," & vbTab & ArrNguon(i, j)
                Else
                    ArrKQ(i, 1) = ArrKQ(i, 1) & vbTab
                End If
            End If
            If j = x Then
                ArrKQ(i, 1) = ArrKQ(i, 1) & ";"
                Exit For
            End If
NextJ:
        Next j
NexX:
        x = 0
        k = 0
    Next i
    For i = LBound(ArrKQ, 1) To UBound(ArrKQ, 1)
        txt = txt & vbTab & ArrKQ(i, 1) & ChrW(10)
    Next i
    txt = Replace(Replace(txt, vbTab & ",", ","), """"",", ",")
GPE = txt
End Function
Sub XuatKetQua()
    TaoFile "D:\KetQua.txt", GPE(Range("A1:J16")) '<=thay d?i vùng d? li?u ? dây
End Sub

copy code TaoFile bên trên dùng chung với code mới này nha

Mutants Men · 10/7/17

lythanh1505 đã viết:
Mình thử chạy, mà toàn thấy lỗi.

lỗi thế nào bạn

sanhdieu0911 · 10/7/17

cám ơn bạn nhé, mình đã thử code, có thể mình sử dụng không đúng nên bị lỗi như này:
điểm 167772165, "P2",,,,, 07-06-2017/9:40:22.0, đã về chính xác, nhưng phần enter vẫn chưa khắc phục được bạn à.
Mình thử nêu cách thay đổi file excel chút, bạn xem có hợp lý và dễ viết hơn không thì giúp mình nhé. Vì mình thấy, các dãy số không có quy luật nên mình tách 3 phần đó thành 3 sheet khác nhau, khi xuất ra sẽ xuất thành 3 tên file TXT với cùng tên sheet ở ổ D. đây chỉ là ví dụ thay đổi ghi file excel thôi, nếu đơn giản hơn thì bạn giúp, nếu không, bạn sửa giúp mình code trước nhé. cám ơn bạn nhiều.
Mình gửi bạn file kết quả vừa chạy và file excel mình sửa lại, bạn xem giúp nhé.

Mutants Men · 11/7/17

sanhdieu0911 đã viết:
khi xuất ra sẽ xuất thành 3 tên file TXT với cùng tên sheet ở ổ D.

trong 1 ổ không thể có 2 file cùng tên + cùng đuôi mở rộng bạn nhé
bạn gửi mình file gốc xuất từ máy ra đi thì mình mới biết chỗ xuống dòng đó là gì mới được.
theo file bạn gửi thì nó là enter.
code trước bạn sửa dòng này

Mã:

txt = Replace(Replace(txt, vbTab & ",", ","), """"",", ",")

thành

Mã:

txt = Replace(Replace(txt, vbTab & ",", ","), """"",", " ,")

sanhdieu0911 · 11/7/17

Cám ơn bạn đã rất nhiệt tình giúp mình rồi. Thực ra không phải cùng tên, ý mình là ở sheet 1 ( toado) sẽ xuất toado.txt, sheet 2 (info) xuất info.txt, sheet 3 (góc) xuất Góc.txt vì như thế, số liệu sẽ được phân tách theo quy luật, không bị lẫn lộn. mình gửi bạn file idx
Thực ra, nó là sau dấu ; sẽ xuống dòng rồi mới tab

sanhdieu0911 · 13/7/17

Có ai giúp tôi xử lý phần xuống dòng trong txt với...

Xin code giúp ghi file excel ra file TXT mẫu

sanhdieu0911

Thành viên mới

File đính kèm

Mutants Men

Thành viên thường trực

sanhdieu0911

Thành viên mới

File đính kèm

Mutants Men

Thành viên thường trực

sanhdieu0911

Thành viên mới

File đính kèm

Mutants Men

Thành viên thường trực

sanhdieu0911

Thành viên mới

File đính kèm

lythanh1505

Thành viên mới

Mutants Men

Thành viên thường trực

Mutants Men

Thành viên thường trực

sanhdieu0911

Thành viên mới

File đính kèm

Mutants Men

Thành viên thường trực

sanhdieu0911

Thành viên mới

File đính kèm

sanhdieu0911

Thành viên mới

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

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian