[Vỡ font]VBA đọc từ excel (1 người xem)

[ruahiphop]

Dear các bác,
Hiện tại em đang làm một cái tool đọc file từ excel rồi ghi ra file text theo format riêng
em có vấn đề ở chỗ khi vba đọc những từ trong phiên âm tiếng anh bị vỡ font làm việc in ra cũng ảnh hưởng theo bác nào biết mách giùm em vơi đây là đoạn code của em

Sub Main()
'
' Main Macro
'
' Keyboard Shortcut: Ctrl+d
'
    Application.Goto Reference:="Main"
    Dim sh As Worksheet
    Dim uRange As Range
    Dim Q As String
    Dim A As String
    Dim i As Range
    Dim position: position = 0
    Dim count: count = 0
    Dim arrStore()
    For Each sh In Worksheets
        Set uRange = sh.UsedRange
        For Each i In uRange
            ReDim Preserve arrStore(count + 1)
            If position Mod 2 = 0 Then
                arrStore(count) = "Q:" & i.Value
            Else
                arrStore(count) = "A:" & i.Value
            End If
            position = position + 1
            count = count + 1
        Next
    Next
    If count Then
        tmpFile = CreateObject("Shell.Application").Namespace(16).Self.Path & "\Dictionary.txt"
        iFileNum = FreeFile
        Open tmpFile For Output As iFileNum
        Print #iFileNum, "************ Dictionary ************"
        For count = 0 To UBound(arrStore)
        Print #iFileNum, arrStore(count)
        Next
        Close #iFileNum
    End If
End Sub

dưới đây là 1 cái example bị vỡ font

Q: Airtime (n)

/'eətaɪm/ => Q:Airtime (n)/'e?ta?m/
A: The amount of time that is given to a particular subject on radio or television.

e.g. Advertisers have bought airtime on all the major TV networks.

p/s: em hỏi thêm chút
khi em đọc nguyên value của 1 cell ra thì nó có nhận được phần xuống dòng để out đúng ra file txt xuống dòng không?
qua kia em làm 1 cái tool out từ excel ra mail format thì được nhưng lần này em đọc ra file txt thì nó ko xuống dòng bác mách giúp em luôn nhé
Em cám ơn

 

[ndu96081631]

Dear các bác,
Hiện tại em đang làm một cái tool đọc file từ excel rồi ghi ra file text theo format riêng
em có vấn đề ở chỗ khi vba đọc những từ trong phiên âm tiếng anh bị vỡ font làm việc in ra cũng ảnh hưởng theo bác nào biết mách giùm em vơi đây là đoạn code của em


dưới đây là 1 cái example bị vỡ font


p/s: em hỏi thêm chút
khi em đọc nguyên value của 1 cell ra thì nó có nhận được phần xuống dòng để out đúng ra file txt xuống dòng không?
qua kia em làm 1 cái tool out từ excel ra mail format thì được nhưng lần này em đọc ra file txt thì nó ko xuống dòng bác mách giúp em luôn nhé
Em cám ơn

Chẳng hiểu bạn nói cái gì cả! Thôi thì cho file lên đây và ghi rõ kết quả như thế nào mới là đúng
Ngoài ra xin nói thêm: Code xuất ra txt file theo kiểu Open tmpFile For Output As iFileNum sẽ không dùng được với chuổi tiếng Việt Unicode đâu nha (phải dùng FileSystemObject mới chơi được)

 

[ruahiphop]

Chẳng hiểu bạn nói cái gì cả! Thôi thì cho file lên đây và ghi rõ kết quả như thế nào mới là đúng
Ngoài ra xin nói thêm: Code xuất ra txt file theo kiểu Open tmpFile For Output As iFileNum sẽ không dùng được với chuổi tiếng Việt Unicode đâu nha (phải dùng FileSystemObject mới chơi được)

Em cám ơn Bác
đại loại là thế này

Q:Airtime (n)
/'e?ta?m/ đúng ra nó phải là thế này /'eətaɪm/
A:The amount of time that is given to a particular subject on radio or television.

e.g. Advertisers have bought airtime on all the major TV networks.
Q: Audience (n)

/ '?di?ns / => / 'ɔdiəns /
A:The people who watch or listen to a particular programme, or who see or hear a particular artist's, writer's etc work.

còn hình dạng output thì em muốn nó ra như bên trái bác ạ
giữa các dòng nó có cách dòng như lúc nó đọc vào


Cám ơn Bác

 

[ruahiphop]

có vẻ như em đổi qua kiểu systemobject cũng ko được nó vẫn lỗi chữ như trên bác ạ đây là đoạn code của em If count Then

Dim FSO As FileSystemObject
        Dim FSOFile As TextStream
        Dim FilePath As String
        Dim NoOfLoop As Integer
        Dim tmpString As String
        FilePath = "c:\WriteTest.txt" ' create a test.txt file or change this
         
        Set FSO = New FileSystemObject
         ' opens  file in write mode
        Set FSOFile = FSO.OpenTextFile("C:\Users\Spring\Desktop\Dictionary.txt", 2, True)
         'loop round adding lines
        For count = 0 To UBound(arrStore)
             ' write your code here
            tmpString = arrStore(count)
            FSOFile.WriteLine tmpString
        Next
         
        FSOFile.Close
    End If

 

[ndu96081631]

có vẻ như em đổi qua kiểu systemobject cũng ko được nó vẫn lỗi chữ như trên bác ạ đây là đoạn code của em If count Then

Dim FSO As FileSystemObject
        Dim FSOFile As TextStream
        Dim FilePath As String
        Dim NoOfLoop As Integer
        Dim tmpString As String
        FilePath = "c:\WriteTest.txt" ' create a test.txt file or change this
         
        Set FSO = New FileSystemObject
         ' opens  file in write mode
        Set FSOFile = FSO.OpenTextFile("C:\Users\Spring\Desktop\Dictionary.txt", 2, True)
         'loop round adding lines
        For count = 0 To UBound(arrStore)
             ' write your code here
            tmpString = arrStore(count)
            FSOFile.WriteLine tmpString
        Next
         
        FSOFile.Close
    End If

Bạn đưa file giả lập lên có phải hơn không! Muốn test giúp bạn thì lấy cái quái gì để test đây chứ?

 

[ruahiphop]

sr bác ^^ em đưa lên đây

 

[ndu96081631]

sr bác ^^ em đưa lên đây

Đoán và làm đại:

Option Explicit
Sub Main()
  Dim sh As Worksheet, uRange As Range, Clls As Range
  Dim tmpString As String, txtFile As String, tmp As String
  Dim count As Long
  Dim arrStore() As String
  ReDim arrStore(0)
  arrStore(0) = "************ Dictionary ************"
  For Each sh In Worksheets
    Set uRange = sh.UsedRange
    For Each Clls In uRange
      If Trim(Clls.Value) <> "" Then
        tmp = Replace(Clls.Value, vbLf, vbCrLf)
        ReDim Preserve arrStore(count + 1)
        If count Mod 2 = 0 Then
          arrStore(count + 1) = "Q: " & tmp
        Else
          arrStore(count + 1) = "A: " & tmp
        End If
        count = count + 1
      End If
    Next
  Next
  If count Then
    tmpString = Join(arrStore, vbCrLf)
    txtFile = CreateObject("Shell.Application").Namespace(16).Self.Path & "\Dictionary.txt"
    With CreateObject("Scripting.FileSystemObject")
      With .CreateTextFile(txtFile, True, True)
        .Write tmpString: .Close
      End With
    End With
  End If
End Sub

 

[ruahiphop]

Bác có thể giải thích giúp em cái vbLF và đoạn join vblf với được không ạ.
cám ơn Bác nhiều

 

[ndu96081631]

Bác có thể giải thích giúp em cái vbLF và đoạn join vblf với được không ạ.
cám ơn Bác nhiều

Là Join(arrStore, vbCrLf) chứ
Trong Excel, nếu mình gõ gì đó vào cell, xong, bấm Alt + Enter thì sẽ xuống dòng... và ký tự xuống dòng (Alt + Enter) chính là Chr(10) <===> vbLf
Trong txt file, ký tự xuống dòng không phải là Chr(10) mà là Chr(10) + Chr(13) <===> vbCrLf
Trong file của bạn, 1 vài cell có ký tự xuống dòng vbLf... Để cho nó cũng xuống dòng trong file txt, ta phải đổi vbLf thành vbCrLf (cho phù hợp)
Còn cái vụ Join(arrStore, vbCrLf) chẳng qua là tôi làm khác bạn 1 chút:
- Bạn đưa từng dòng vào file txt (bằng lệnh WriteLine)
- Tôi đưa 1 lần vào file txt sau khi đã nối các phần tử trong mảng lại với nhau (bằng lệnh Write)
Thế thôi