Copy nội dung và tiêu đề file txt sang xls bằng Macro

[nguyenhoang_roland]

Xin chào toàn thể anh em GPE. Mình là thành viên mới và đang tập tành Macro để áp dụng trong công việc.
Hiện tại, mình muốn copy nội dung từ file txt sang xls bằng macro (cái này mình làm theo sự hướng dẫn trên forums ok). Nhưng mình muốn bổ sung thêm copy tên file với nội dung luôn để không bị nhầm dữ liệu khi xử lý (vì có rất nhiều file txt cùng nội dung chỉ khác tên file).

Mong mọi người giúp mình chỉnh sửa code nhé. Code mình copy và chỉnh sửa từ forums.

Sub Main()
Dim vFile, txtFile, aCols, aRows, Arr
Dim sAll As String, tmp As String
Dim fso As Object
Dim lR As Long, lC As Long, n As Long, t As Double
On Error Resume Next
vFile = Application.GetOpenFilename("Text Files, *.txt", , , , True)
If TypeName(vFile) = "Variant()" Then
t = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
For Each txtFile In vFile
With fspenTextFile(txtFile, 1)
sAll = .ReadAll
.Close
End With
aRows = Split(sAll, vbCrLf)
If Not IsArray(Arr) Then ReDim Arr(1 To UBound(aRows), 1 To UBound(vFile))
lC = lC + 1: lR = 0
For n = 0 To UBound(aRows)
tmp = CStr(aRows(n))
If Len(tmp) Then
lR = lR + 1
aCols = Split(tmp, vbTab)
Arr(lR, lC) = aCols(0)
End If
Next
Next
Set fso = Nothing
If lR Then
Range("A1").Resize(lR, lC).Value = Arr
MsgBox "Xong nhe ^_^", , Format(Timer - t, "0.000000")
End If
End If
End Sub


P/S: tên file txt muốn copy vô chung nội dung: 1806-XXXX-XX

Cảm ơn mọi người đã quan tâm và đọc tin.
Nguyenhoang_roland

 

[giaiphap]

Xin chào toàn thể anh em GPE. Mình là thành viên mới và đang tập tành Macro để áp dụng trong công việc.
Hiện tại, mình muốn copy nội dung từ file txt sang xls bằng macro (cái này mình làm theo sự hướng dẫn trên forums ok). Nhưng mình muốn bổ sung thêm copy tên file với nội dung luôn để không bị nhầm dữ liệu khi xử lý (vì có rất nhiều file txt cùng nội dung chỉ khác tên file).

Mong mọi người giúp mình chỉnh sửa code nhé. Code mình copy và chỉnh sửa từ forums.

Sub Main()
Dim vFile, txtFile, aCols, aRows, Arr
Dim sAll As String, tmp As String
Dim fso As Object
Dim lR As Long, lC As Long, n As Long, t As Double
On Error Resume Next
vFile = Application.GetOpenFilename("Text Files, *.txt", , , , True)
If TypeName(vFile) = "Variant()" Then
t = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
For Each txtFile In vFile
With fspenTextFile(txtFile, 1)
sAll = .ReadAll
.Close
End With
aRows = Split(sAll, vbCrLf)
If Not IsArray(Arr) Then ReDim Arr(1 To UBound(aRows), 1 To UBound(vFile))
lC = lC + 1: lR = 0
For n = 0 To UBound(aRows)
tmp = CStr(aRows(n))
If Len(tmp) Then
lR = lR + 1
aCols = Split(tmp, vbTab)
Arr(lR, lC) = aCols(0)
End If
Next
Next
Set fso = Nothing
If lR Then
Range("A1").Resize(lR, lC).Value = Arr
MsgBox "Xong nhe ^_^", , Format(Timer - t, "0.000000")
End If
End If
End Sub


P/S: tên file txt muốn copy vô chung nội dung: 1806-XXXX-XX

Cảm ơn mọi người đã quan tâm và đọc tin.
Nguyenhoang_roland

Vấn đề là lấy tên file đặt vào chổ nào trong sheet mới được chứ.

 

[nguyenhoang_roland]

Vấn đề là lấy tên file đặt vào chổ nào trong sheet mới được chứ.

Cảm ơn sự quan tâm của bạn. Mình có thể đặt tên file tương ứng với nội dung copy. (sau nội dung Au: 3 giá trị ~> tên file A20)

 

[giaiphap]

Cảm ơn sự quan tâm của bạn. Mình có thể đặt tên file tương ứng với nội dung copy. (sau nội dung Au: 3 giá trị ~> tên file A20)

Sửa code lại thế này.

Sub Main()
  Dim vFile, txtFile, aCols, aRows, Arr
  Dim sAll As String, tmp As String
  Dim fso As Object
  Dim lR As Long, lC As Long, n As Long, t As Double
  On Error Resume Next
  vFile = Application.GetOpenFilename("Text Files, *.txt", , , , True)
  If TypeName(vFile) = "Variant()" Then
    t = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each txtFile In vFile
      With fso.OpenTextFile(txtFile, 1)
        sAll = .ReadAll
        .Close
      End With
      aRows = Split(sAll, vbCrLf)
      If Not IsArray(Arr) Then ReDim Arr(1 To UBound(aRows) + 1, 1 To UBound(vFile))
     lC = lC + 1: lR = 0
      For n = 0 To UBound(aRows)
        tmp = CStr(aRows(n))
        If Len(tmp) Then
          lR = lR + 1
          aCols = Split(tmp, vbTab)
          Arr(lR, lC) = aCols(0)
        End If
      Next
      aCols = Split(txtFile, "\")
      Arr(lR + 1, lC) = aCols(UBound(aCols))
    Next
    Set fso = Nothing
    If lR Then
      Range("A1").Resize(lR + 1, lC).Value = Arr
      MsgBox "Xong nhe ^_^", , Format(Timer - t, "0.000000")
    End If
  End If
End Sub

 

[nguyenhoang_roland]

Cam ơn bạn nhé. Quá tuyệt vời. Chúc bạn nhiều sức khỏe và thanh công ^_^

 

[nguyenhoang_roland]

Sửa code lại thế này.

End Sub[/CODE]

Tình hình là sau khi mình copy cùng lúc 3 file bên dưới thì có 1 file không copy được tên file. Bạn giaiphap giúp mình kiểm tra lại nhé. Mình không rành lắm.

Xin lỗi đã làm phiền bạn và cảm ơn bạn rất nhiều.
Nguyenhoang_roland

 

[nguyenhoang_roland]

Sửa code lại thế này.

End Sub[/CODE]

Mong bạn giúp mình trường hợp này nhé. Cảm ơn bạn rất nhiều.
Nguyenhoang_roland

 

[giaiphap]

Mong bạn giúp mình trường hợp này nhé. Cảm ơn bạn rất nhiều.
Nguyenhoang_roland

Sửa lại thế này.

Sub Main()
  Dim vFile, txtFile, aCols, aRows, Arr
  Dim sAll As String, tmp As String
  Dim fso As Object
  Dim lR As Long, lC As Long, n As Long, t As Double, Max As Long
  On Error Resume Next
  vFile = Application.GetOpenFilename("Text Files, *.txt", , , , True)
  If TypeName(vFile) = "Variant()" Then
    t = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each txtFile In vFile
      With fso.OpenTextFile(txtFile, 1)
        sAll = .ReadAll
        .Close
      End With
      aRows = Split(sAll, vbCrLf)
     If Not IsArray(Arr) Then ReDim Arr(1 To 1000, 1 To UBound(vFile))
    
     lC = lC + 1: lR = 0
      For n = 0 To UBound(aRows)
        tmp = CStr(aRows(n))
        If Len(tmp) Then
          lR = lR + 1
          aCols = Split(tmp, vbTab)
          Arr(lR, lC) = aCols(0)
        End If
      Next
      aCols = Split(txtFile, "\")
      Arr(lR + 1, lC) = aCols(UBound(aCols))
      If Max < lR + 1 Then Max = lR + 1
    Next
    Set fso = Nothing
    If Max Then
      Range("A1").Resize(Max, lC).Value = Arr
      MsgBox "Xong nhe ^_^", , Format(Timer - t, "0.000000")
    End If
  End If
End Sub

 

[nguyenhoang_roland]

Sửa lại thế này.

End Sub[/CODE]

Thật sự cảm ơn bạn rất nhiều. Chúc bạn nhiều sức khỏe.
Cảm ơn Forums GPE, rất bổ ích cho bản thân mình.
Thân
Nguyenhoang_roland