Code gộp file

[nh0c_nhoem]

Em xin chào mọi người,

Em có đoạn code gộp file excel như bên dưới. và em muốn viết thêm cột tên file để dễ dàng nhận biết dữ liệu được dữ liệu được gộp là của file excel nào. (code em copy ở trên mạng mà em không biết gì về code nên không viết được). Em cám ơn.

Sub MergeFilesExcel()
Rows("2:999999").Select
    Selection.Delete Shift:=xlUp
Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 1

    ThisWB = ActiveWorkbook.Name
  
    'Dien duong dan folder chua cac tap tin excel can gom lai.
    'Nhu ban thay toi tien duong dan thu muc chua cai file excel cua toi.
    path = "D:\CC\JT"

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("a" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
      
        Filename = Dir()
    Loop

    Range("A1").Select
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  
    MsgBox "DATA DA XONG!HAVE A GOOD DAY"
    
End Sub

 

[Hoàng Nhật Phương]

Em xin chào mọi người,

Em có đoạn code gộp file excel như bên dưới. và em muốn viết thêm cột tên file để dễ dàng nhận biết dữ liệu được dữ liệu được gộp là của file excel nào. (code em copy ở trên mạng mà em không biết gì về code nên không viết được). Em cám ơn.

Sub MergeFilesExcel()
Rows("2:999999").Select
    Selection.Delete Shift:=xlUp
Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 1

    ThisWB = ActiveWorkbook.Name
 
    'Dien duong dan folder chua cac tap tin excel can gom lai.
    'Nhu ban thay toi tien duong dan thu muc chua cai file excel cua toi.
    path = "D:\CC\JT"

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("a" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
     
        Filename = Dir()
    Loop

    Range("A1").Select
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
    MsgBox "DATA DA XONG!HAVE A GOOD DAY"
   
End Sub

Bạn sửa từ dòng này:

            Set Dest = shtDest.Range("a" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False

Sửa thành:

            Set Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Dest.Offset(, -1).Resize(ActiveSheet.UsedRange.Rows.Count).Value = Filename
            Wkb.Close False

 

[nh0c_nhoem]

Cám ơn bạn Oanh Thơ đã giúp mình nhé.