Nhờ anh ndu96081631 và các bạn giúp em về đoạn code VBA với

[vanlemon]

Em xin kính chào các anh/ chị trên diễn đàn

Tình hình là em muốn dùng VBA mở 1 vài file *.TXT trong một Folder

Em lên mạng search thấy anh ndu96081631 có một đoạn code như dưới đây:

Tuy nhiên em muốn thêm một số thuộc tính khi mở file TXT như sau thì cần viết Code như thế nào ạ?
Giả sử em có 5 file TXT. Bây giờ mở ra được 5Sheet rồi thì em muốn copy toàn bộ dữ liệu 5 Sheet này vào 1 Sheet ( Trong đó chỉ Sheet thứ 1 là copy toàn bộ, còn các sheet khác thì chỉ copy từ dòng thứ 2 đến cuối cùng) thì làm như thế nào ạ?

DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, _ FieldInfo:=arr, TrailingMinusNumbers:=True

Code của anh ndu96081631

Function GetListFile(ByVal Folder As String, ByVal Search As String, ByVal InSub As Boolean) Dim sComm As String, tmp As String, tmpFile, Arr
On Error Resume Next
If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
Folder = """" & Folder & """"
With CreateObject("Scripting.FileSystemObject")
tmpFile = .GetTempName
sComm = "DIR " & Folder & Search & " /ON /B /A-D " & IIf(InSub, "/S", " ") & " >" & tmpFile
CreateObject("Wscript.Shell").Run "cmd /u /c " & sComm, 0, True
With .OpenTextFile(tmpFile, 1, , -2)
tmp = Trim(.ReadAll)
If Right(tmp, 2) = vbCrLf Then tmp = Left(tmp, Len(tmp) - 2)
If Len(tmp) Then GetListFile = Split(tmp, vbCrLf)
.Close
End With
End With
Kill tmpFile
End Function




Code:
Function GetValFromTxt(ByVal txtFile As String)
Dim tmpArr, Arr()
Dim n As Long, i As Long
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
If .FileExists(txtFile) Then
With .OpenTextFile(txtFile, 1, , -2)
tmpArr = Split(.ReadAll, vbCrLf)
If IsArray(tmpArr) Then
ReDim Arr(1 To UBound(tmpArr) + 1, 1 To 1)
For i = 0 To UBound(tmpArr)
n = n + 1
Arr(n, 1) = CStr(tmpArr(i))
Next
If n Then GetValFromTxt = Arr
End If
.Close
End With
End If
End With
End Function
2> Code chính:




Code:
Sub Main()
Dim sFolder, txtFile As String, sWksName As String
Dim aFiles, Arr, wkbNew As Workbook
Dim lCount As Long, i As Long, n As Long, lWksCount As Long
On Error Resume Next
With CreateObject("Shell.Application")
sFolder = .BrowseForFolder(0, "", 1).Self.Path
End With
If TypeName(sFolder) = "String" Then
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
aFiles = GetListFile(sFolder, "*.txt", False)
If IsArray(aFiles) Then
lCount = UBound(aFiles) + 1
ReDim Arr(1 To lCount)
Set wkbNew = Workbooks.Add
With wkbNew
lWksCount = lCount - .Sheets.Count
If lWksCount > 0 Then
.Worksheets.Add After:=.Sheets(.Sheets.Count), Count:=lWksCount
End If
End With
With CreateObject("Scripting.FileSystemObject")
For i = 0 To UBound(aFiles)
txtFile = sFolder & aFiles(i)
sWksName = Left(aFiles(i), InStrRev(aFiles(i), ".") - 1)
n = n + 1
Arr = GetValFromTxt(txtFile)
With wkbNew.Sheets(n)
.Range("A1").Resize(UBound(Arr)).Value = Arr
.Name = Left(sWksName, 31)
End With
Next
End With
End If
End If
End Sub

 

[vanlemon]

Có anh/ chị nào giúp em với ạ.