Tổng hợp dữ liệu từ các tập tin *.txt, *.csv - Combine data from *.txt or *.csv files

[levanduyet]

Tổng hợp dữ liệu từ các tập tin *.txt, *.csv - Combine data from *.txt or *.csv files

Tổng hợp dữ liệu từ các tập tin Excel tôi đã giới thiệu các bài của rondebruin, nay tôi xin giới thiệu loạt bài tương tự nhưng với các tập tin *.txt hoặc *.csv của cùng Tác giả.
Bài viết của Tác giả rondebruin có tính chọn lọc cao, các đoạn mã dễ hiểu và dễ áp dụng.

Macro sau sẽ copy nội dung của mỗi tập tin *.txt mà bạn chọn với GetOpenFilename
Nếu bạn chọn 10 tập tin txt trong thư mục, dữ liệu của mỗi tập tin txt sẽ được đưa vào một worksheet trong cùng một workbook. Tên mỗi worksheet cũng là tên của tập tin txt này.

Chú ý: bạn có thể nhấn phím CTRL để chọn các tập tin không liên tục hoặc phím Shift để chọn các tập tin liên tục.

Cách sử dụng:
Bạn copy tất cả đoạn mã bên dưới vào một module workbook của bạn.

• Nhấn tổ hợp phím: Alt F11
• Chọn Insert Module
• Dán đoạn mã vào
• Nhấn tổ hợp phím Alt + q để trở về màn hình Excel
• Nhấn tổ hợp phím Alt + F8 để mở hộp thoại Macro Dialog
• Chọn Macro bạn muốn thực hiện và nhấn nút Run

Ví dụ này áp dụng cho tập tin Delimited txt (tức là các trường ngăn cách bởi một Delimiter), đối với tập tin text FixedWidth (nội dung các hàng là như nhau) thì xin đọc phần cuối để thay đổi cho phù hợp.

Ví dụ dạng của một Delimited txt, với ký tự ngăn cách các trường là ";" :

MaSP; TenSP; SL
A21; Sản phẩm A21; 5
B11; Sản phẩm B11; 15

Ví dụ dạng của một FixedWidth :

[COLOR="Red"]1[/COLOR]234567890[COLOR="Red"]1[/COLOR]234567890[COLOR="Red"]1[/COLOR]234567890[COLOR="Red"]1[/COLOR]234567890[COLOR="Red"]1[/COLOR]234567890
MaSP      TenSP               SL
A21       Sản phẩm A21        5
B11       Sản phẩm B11        15

Private Declare Function SetCurrentDirectoryA Lib _
        "kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    ChDirNet = CBool(lReturn <> 0)
End Function

Sub Get_TXT_Files()
'Sử dụng cho Excel 2000 về sau
    Dim Fnum As Long
    Dim mysheet As Worksheet
    Dim basebook As Workbook
    Dim TxtFileNames As Variant
    Dim QTable As QueryTable
    Dim SaveDriveDir As String
    Dim ExistFolder As Boolean
[COLOR="Teal"]
    'Lưu thư mục hiện hành[/COLOR]
    SaveDriveDir = CurDir

  [COLOR="Teal"]  'Bạn có thể thay đổi thư mục bắt đầu khi bạn dùng với GetOpenFilename
    '
    'Ví dụ ChDirNet("C:\Users\Ron\test")
    'Ở ví dụ này dùng thư mục mặc định của Excel
    'Bạn có thể thiết lập trong Excel 2007 bằng cách
    'Excel Options>Save>Default file location[/COLOR]

    ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Lỗi thay đổi thư mục."
        Exit Sub
    End If

    TxtFileNames = Application.GetOpenFilename _
    (filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)

    If IsArray(TxtFileNames) Then

        On Error GoTo CleanUp

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

       [COLOR="Green"] 'Thêm một workbook có một sheet[/COLOR]
        Set basebook = Workbooks.Add(xlWBATWorksheet)
[COLOR="SeaGreen"]
        'Duyệt qua mảng chứa các tập tin txt[/COLOR]
        For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
[COLOR="SeaGreen"]
            'Thêm một worksheet mới với tên là tên của tập tin txt [/COLOR]
            Set mysheet = Worksheets.Add(After:=basebook. _
                                Sheets(basebook.Sheets.Count))
            On Error Resume Next
            mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
                                    InStrRev(TxtFileNames(Fnum), "\", , 1))
            On Error GoTo 0

            With ActiveSheet.QueryTables.Add(Connection:= _
                        "TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1

               [COLOR="SeaGreen"] 'Ví dụ này dùng [/COLOR][COLOR="Red"]xlDelimited[/COLOR]
         [COLOR="SeaGreen"]       'Xem ví dụ cho [/COLOR][COLOR="Red"]xlFixedWidth[/COLOR] [COLOR="SeaGreen"]ở cuối macro[/COLOR]
                .TextFileParseType = xlDelimited

  [COLOR="SeaGreen"]              'Thiết lập dấu phân cách (Set your Delimiter) là True[/COLOR]
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
[COLOR="SeaGreen"]
                'Thiết lập định dạng cho mỗi cột nếu bạn muốn (Mặc định là General/Default = General)
                'Ví dụ Array(1, 9, 1) là không định dạng cột thứ hai[/COLOR]

                .TextFileColumnDataTypes = Array(1, 9, 1)

                'xlGeneralFormat  General          1
                'xlTextFormat     Text             2
                'xlMDYFormat      Month-Day-Year   3
                'xlDMYFormat      Day-Month-Year   4
                'xlYMDFormat      Year-Month-Day   5
                'xlMYDFormat      Month-Year-Day   6
                'xlDYMFormat      Day-Year-Month   7
                'xlYDMFormat      Year-Day-Month   8
                'xlSkipColumn     Skip             9
[COLOR="SeaGreen"]
                ' Lấy dữ liệu từ tập tin txt[/COLOR]
                .Refresh BackgroundQuery:=False
            End With
		ActiveSheet.QueryTables(1).Delete
        Next Fnum

        'Xóa sheet đầu tiên của basebook
        On Error Resume Next
        Application.DisplayAlerts = False
        basebook.Worksheets(1).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

CleanUp:
       [COLOR="SeaGreen"] ' Trả về lại thư mục mặc định như trước khi thực hiện macro[/COLOR]
        ChDirNet SaveDriveDir

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

Nếu bạn muốn áp dụng cho tập tin text FixedWidth


Bạn hãy thay thế đoạn mã sau trong macro ở trên :

               [COLOR="SeaGreen"] 'Ví dụ này dùng [/COLOR][COLOR="Red"]xlDelimited[/COLOR]
         [COLOR="SeaGreen"]       'Xem ví dụ cho [/COLOR][COLOR="Red"]xlFixedWidth[/COLOR] [COLOR="SeaGreen"]ở cuối macro[/COLOR]
                .TextFileParseType = xlDelimited

  [COLOR="SeaGreen"]              'Thiết lập dấu phân cách (Set your Delimiter) là True[/COLOR]
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False

Bằng đoạn mã này:

                .TextFileParseType = xlFixedWidth

[COLOR="SeaGreen"]                'Thiết lập độ rộng cho mỗi cột[/COLOR]
                .TextFileFixedColumnWidths = Array(5, 4, 8)[COLOR="SeaGreen"] 'Có nghĩa là cột 1: 5 ký tự; cột 2: 4 ký tự; cột 3: 8 ký tự[/COLOR]

Đối với tập tin csv, bạn dùng đoạn mã sau:

Private Declare Function SetCurrentDirectoryA Lib _
            "kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    ChDirNet = CBool(lReturn <> 0)
End Function


Sub Get_CSV_Files()
'Áp dụng cho Excel 2000 trở về sau
    Dim Fnum As Long
    Dim mybook As Workbook
    Dim basebook As Workbook
    Dim CSVFileNames As Variant
    Dim SaveDriveDir As String
    Dim ExistFolder As Boolean

    'Lưu thư mục hiện hành
    SaveDriveDir = CurDir

     [COLOR="Teal"]  'Bạn có thể thay đổi thư mục bắt đầu khi bạn dùng với GetOpenFilename
    '
    'Ví dụ ChDirNet("C:\Users\Ron\test")
    'Ở ví dụ này dùng thư mục mặc định của Excel
    'Bạn có thể thiết lập trong Excel 2007 bằng cách
    'Excel Options>Save>Default file location[/COLOR]

    ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Error changing folder"
        Exit Sub
    End If

    CSVFileNames = Application.GetOpenFilename _
        (filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)

    If IsArray(CSVFileNames) Then

        On Error GoTo CleanUp

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
[COLOR="SeaGreen"]
        'Thêm workbook có mộtsheet[/COLOR]
        Set basebook = Workbooks.Add(xlWBATWorksheet)

 [COLOR="SeaGreen"]       'Duyệt qua mảng chứa tên các tập tin csv [/COLOR]
        For Fnum = LBound(CSVFileNames) To UBound(CSVFileNames)

            Set mybook = Workbooks.Open(CSVFileNames(Fnum))

[COLOR="SeaGreen"]            'Copysheet của tập tin csv vào sau sheet cuối cùng trongn
            'basebook (this is the new workbook)[/COLOR]
            mybook.Worksheets(1).Copy After:= _
                                      basebook.Sheets(basebook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = Right(CSVFileNames(Fnum), Len(CSVFileNames(Fnum)) - _
                                            InStrRev(CSVFileNames(Fnum), "\", , 1))
            On Error GoTo 0

            mybook.Close savechanges:=False

        Next Fnum

[COLOR="SeaGreen"]        'Xóa sheet đầu tiên của basebook[/COLOR]
        On Error Resume Next
        Application.DisplayAlerts = False
        basebook.Worksheets(1).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

CleanUp:
[COLOR="SeaGreen"]        ' Trả về thư mục mặc định ban đầu[/COLOR]
        ChDirNet SaveDriveDir

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

Nguồn từ đây.

 

[levanduyet]

Áp dụng cụ thể:

Tôi có một tập tin chấm công chamcong.dat được xuất ra từ máy chấm công, như hình sau:

Tôi cần nhập số liệu này vào Excel, tôi sẽ chỉnh sửa lại một chút cho đoạn code ở trên:

Đầu tiên, do tập tin của tôi có định dạng *.dat nên tôi sẽ chỉnh sửa lại đoạn mã này:

TxtFileNames = Application.GetOpenFilename _
     (FileFilter:="[COLOR="Red"]TXT Files (*.txt), *.txt"[/COLOR], MultiSelect:=True)

Thành

TxtFileNames = Application.GetOpenFilename _
                   (FileFilter:="[COLOR="Red"]TXT Files (*.dat), *.dat"[/COLOR], MultiSelect:=True)

Sau đó do tập tin của tôi thuộc dạng FixedWidth, nên tôi sẽ sửa lại đoạn mã:

.TextFileParseType = xlFixedWidth

Và

[COLOR="SeaGreen"]     ' Cột một 5 ký tự, cột thứ hai 11 ký tự, cột thứ ba 9 ký tự,....[/COLOR]
     .TextFileFixedColumnWidths = Array(5, 11, 9, 2, 2, 2, 2)
     ' Cột một dạng General, cột hai dạng ngày yyyy-mm-dd, từ cột ba trở đi cũng dạng General
     .TextFileColumnDataTypes = Array(1, 5, 1, 1, 1, 1, 1)

Cuối cùng tôi sửa lại tên của thủ tục thành Get_Data

Sub [COLOR="Red"]Get_Data[/COLOR]()
    'Su+? du.ng cho Excel 2000 ve^` sau
    Dim Fnum   As Long
    Dim mysheet As Worksheet
    Dim basebook As Workbook
    Dim TxtFileNames As Variant
    Dim QTable As QueryTable
    Dim SaveDriveDir As String
    Dim ExistFolder As Boolean

    'Lu+u thu+ mu.c hie^.n hành
    SaveDriveDir = CurDir

    'Ba.n có the^? thay ?o^?i thu+ mu.c ba('t ?a^`u khi ba.n dùng vo+'i GetOpenFilename
    '
    'Ví du. ChDirNet("C:\Users\Ron\test")
    'O+? ví du. này dùng thu+ mu.c ma(.c ?i.nh cu?a Excel
    'Ba.n có the^? thie^'t la^.p trong Excel 2007 ba(`ng cách
    'Excel Options>Save>Default file location

    ExistFolder = ChDirNet(Application.DefaultFilePath)
    If ExistFolder = False Then
        MsgBox "Lo^~i thay ?o^?i thu+ mu.c."
        Exit Sub
    End If

    'TxtFileNames = Application.GetOpenFilename _
     (FileFilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)
    TxtFileNames = Application.GetOpenFilename _
                   (FileFilter:="TXT Files (*.dat), *.dat", MultiSelect:=True)

    If IsArray(TxtFileNames) Then

        On Error GoTo CleanUp

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        'Thêm mo^.t workbook có mo^.t sheet
        Set basebook = Workbooks.Add(xlWBATWorksheet)

        'Duye^.t qua ma?ng chu+'a các ta^.p tin txt
        For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)

            'Thêm mo^.t worksheet mo+'i vo+'i tên là tên cu?a ta^.p tin txt
            Set mysheet = Worksheets.Add(After:=basebook. _
                                                Sheets(basebook.Sheets.Count))
            On Error Resume Next
            mysheet.NAME = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
                                                     InStrRev(TxtFileNames(Fnum), "\", , 1))
            On Error GoTo 0

            With ActiveSheet.QueryTables.Add(Connection:= _
                                             "TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
                .TextFilePlatform = xlWindows
                .TextFileStartRow = 1

                'Ví du. này dùng xlDelimited
                'Xem ví du. cho xlFixedWidth o+? cuo^'i macro
                .TextFileParseType = xlFixedWidth
                'Thie^'t la^.p ?o^. ro^.ng cho mo^~i co^.t
                .TextFileFixedColumnWidths = Array(5, 11, 9, 2, 2, 2, 2)


                'Thie^'t la^.p ?i.nh da.ng cho mo^~i co^.t ne^'u ba.n muo^'n (Ma(.c ?i.nh là General/Default = General)
                'Ví du. Array(1, 9, 1) là không ?i.nh da.ng co^.t thu+' hai

                .TextFileColumnDataTypes = Array(1, 5, 1, 1, 1, 1, 1)

                'xlGeneralFormat  General          1
                'xlTextFormat     Text             2
                'xlMDYFormat      Month-Day-Year   3
                'xlDMYFormat      Day-Month-Year   4
                'xlYMDFormat      Year-Month-Day   5
                'xlMYDFormat      Month-Year-Day   6
                'xlDYMFormat      Day-Year-Month   7
                'xlYDMFormat      Year-Day-Month   8
                'xlSkipColumn     Skip             9

                ' La^'y du+~ lie^.u tu+` ta^.p tin txt
                .Refresh BackgroundQuery:=False
            End With
            ActiveSheet.QueryTables(1).Delete
        Next Fnum

        'Xóa sheet ?a^`u tiên cu?a basebook
        On Error Resume Next
        Application.DisplayAlerts = False
        basebook.Worksheets(1).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

CleanUp:
        ' Tra? ve^` la.i thu+ mu.c ma(.c ?i.nh nhu+ tru+o+'c khi thu+.c hie^.n macro
        ChDirNet SaveDriveDir

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If

End Sub

Sau đó tôi thực hiện thủ tục này và được dữ liệu như sau:

Bạn hãy xem tập tin đính kèm.

Lê Văn Duyệt