Tổng dữ liệu từ nhiều File Text vào 1 Sheets của File Excel (1 người xem)

[baquang1984]

Em đã tham khảo các bài viết của diễn đàn về phương thức tổng hợp File Text vào File Excel, tuy nhiên khi em áp dụng vào File Text của mình thì lại không được có khả năng định dạng File Text của em khác với các bài đã đưa trên diễn đàn.
Em muốn nhờ các anh chị trên diễn đàn Code VBA giúp em chương trình tổng hợp từ nhiều File Text vào File Excel giống như File Excel trong thư mục đính Kèm.
Khi đưa dữ liệu vào thì chỉ cần một hàng tiêu đề còn dữ liệu được tổng hợp tuần tự theo các File Text
Em cảm ơn anh chị rất nhiều!

 

[baquang1984]

Em đã tham khảo Code VBA của anh sealand để áp dụng vào công việc với file text em gửi file đính kèm ở trên tuy nhiên chương trình chạy ra thì bị lỗi không chạy được với file Text của em gửi mong được mọi người giúp đỡ. Dười đây là Code VBA của sealand.
Thanks all!

Option Explicit
Sub Main()
 Dim ListF, i
 Application.ScreenUpdating = False
  ListF = Application.GetOpenFilename("Text Files (*.txt), *.txt" _
    , , "Select *.txt Files", , True)
     If IsArray(ListF) Then
       Sheet4.Cells.ClearContents
      For i = LBound(ListF) To UBound(ListF)
    GetDT ListF(i), i = LBound(ListF)
    Next
  End If
End Sub
Sub GetDT(ByVal FName As String, tde As Boolean)
  Dim Data As Variant, Tmp As Variant, Sh As Integer
   Dim Kq(), k, j, n
   Dim Alas
   Tmp = Split(FName, "\")
   Alas = Replace(Tmp(UBound(Tmp)), ".txt", "")
    Sh = FreeFile
     Open FName For Input As #Sh
Do Until EOF(Sh)
 n = n + 1
   Line Input #Sh, Data
      Tmp = Split(Data, "|")
        If IsArray(Tmp) And n > IIf(tde, 0, 3) Then
          k = k + 1
        ReDim Preserve Kq(1 To 13, 1 To k)
       
       If n > 3 Then Kq(1, k) = Alas
      For j = 1 To UBound(Tmp)
    Kq(j + 1, k) = Trim(Tmp(j))
  Next
 End If
Loop
Close #1
If tde Then Kq(1, 2) = "T" & Chr(234) & " BD"
Sheet4.[A65536].End(3).Offset(IIf(tde, 0, 1)).Resize(UBound(Kq, 2), _
UBound(Kq, 1)) = WorksheetFunction.Transpose(Kq)
End Sub

 

[nmhung49]

Em đã tham khảo Code VBA của anh sealand để áp dụng vào công việc với file text em gửi file đính kèm ở trên tuy nhiên chương trình chạy ra thì bị lỗi không chạy được với file Text của em gửi mong được mọi người giúp đỡ. Dười đây là Code VBA của sealand.
Thanks all!

Thử code này đã sửa
[GPECODE=vb]
Sub Main()
Dim ListF, i As Long
Application.ScreenUpdating = False
ListF = Application.GetOpenFilename("Text Files (*.txt), *.txt" _
, , "Select *.txt Files", , True)
If IsArray(ListF) Then
Sheet1.UsedRange.Offset(1).ClearContents
For i = LBound(ListF) To UBound(ListF)
GetDT ListF(i), i = LBound(ListF)
Next
End If
End Sub
Sub GetDT(ByVal FName As String, tde As Boolean)
Dim Data As Variant, Tmp As Variant, Sh As Integer
Dim Kq(), k, j, dong As Long
ReDim Kq(1 To 1000, 1 To 50)
' thay doi 1000 la dong txt file neu nhiu hon thi thay doi, 50 la so cot txt file neu nhiu hon thi thay doi
Tmp = Split(FName, "\")
Sh = FreeFile
k = 0: dong = 0
Open FName For Input As #Sh


Do Until EOF(Sh)

Line Input #Sh, Data
dong = dong + 1
Tmp = Split(Data, vbTab)
If dong > 1 Then
If IsArray(Tmp) Then
k = k + 1
For j = 0 To UBound(Tmp)
Kq(k, j + 1) = Trim(Tmp(j))
Next
End If
End If


Loop


Close #1
If k Then Sheet1.[A65536].End(3).Offset(1).Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End Sub


[/GPECODE]
Nhớ copy dòng tiêu đề paste ở dòng 1 rồi chạy code.

 

[baquang1984]

Thử code này đã sửa
[GPECODE=vb]
Sub Main()
Dim ListF, i As Long
Application.ScreenUpdating = False
ListF = Application.GetOpenFilename("Text Files (*.txt), *.txt" _
, , "Select *.txt Files", , True)
If IsArray(ListF) Then
Sheet1.UsedRange.Offset(1).ClearContents
For i = LBound(ListF) To UBound(ListF)
GetDT ListF(i), i = LBound(ListF)
Next
End If
End Sub
Sub GetDT(ByVal FName As String, tde As Boolean)
Dim Data As Variant, Tmp As Variant, Sh As Integer
Dim Kq(), k, j, dong As Long
ReDim Kq(1 To 1000, 1 To 50)
' thay doi 1000 la dong txt file neu nhiu hon thi thay doi, 50 la so cot txt file neu nhiu hon thi thay doi
Tmp = Split(FName, "\")
Sh = FreeFile
k = 0: dong = 0
Open FName For Input As #Sh


Do Until EOF(Sh)

Line Input #Sh, Data
dong = dong + 1
Tmp = Split(Data, vbTab)
If dong > 1 Then
If IsArray(Tmp) Then
k = k + 1
For j = 0 To UBound(Tmp)
Kq(k, j + 1) = Trim(Tmp(j))
Next
End If
End If


Loop


Close #1
If k Then Sheet1.[A65536].End(3).Offset(1).Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End Sub


[/GPECODE]

Em cảm ơn nmhung49 đã giúp đỡ tổng hợp file text em làm phiền thêm chút nữa được không ạ. Đối với file text của em gửi là định danh font chữ là .vntime, giờ khi em sử dụng code của nmhung49 để tổng hợp mà muốn chuyển toàn bộ font chữ .vntime (TCVN3) thành Times New Roman (Unicode), nmhung49 và mọi người có thể Code thêm giúp em phần này được không ạThanks all!