Trang 1 của 2 12 CuốiCuối
Kết quả 1 đến 10 của 13

Chủ đề: Add-Ins ghép nhiều file Excel thành 1 file duy nhất

  1. #1
    vlvietlamvl Guest

    Add-Ins ghép nhiều file Excel thành 1 file duy nhất

    Chào các bạn;

    Do nhu cầu công việc nên mình tạo 1 Add-Ins để ghép nhiều file Excel thành 1 file duy nhất. Tiện thể chia sẻ cho anh em dùng và góp ý.

    Tạo Add-Ins có cái hay là chỉ cần nạp 1 lần và sử dụng mãi mãi.

    Yêu cầu:
    - Office 2007 trở lên
    - Các File cần ghép có cấu trúc giống hệt nhau
    - Dữ liệu nằm ở Sheet đầu tiên (không phân biệt tên Sheet)
    - Chỉ hoạt động khi bạn chọn từ 2 file trở lên (vì 1 file thì cần gì ghép nữa [IMG]images/smilies/a01.gif[/IMG])

    Mô tả:
    - Chương trình sẽ ghép tất cả các File đã chọn thành 1 File duy nhất tại thư mục chứa các File đang chọn và có tên là "Tong hop ddmmyyyy hhmmss.xlsx"
    - Khi chọn xong các File, chương trình đọc lần lượt từng File. Với File đầu tiên thì sẽ Copy toàn bộ dữ liệu, các file tiếp theo sẽ copy dữ liệu từ hàng thứ 2.
    - Khi xong chương trình tự lưu lại.

    Note: Mình để Open Source để các bạn muốn thì tham khảo và góp ý.

  2. #2
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Trích dẫn Gửi bởi thinh18tt
    Chào các bạn;

    Do nhu cầu công việc nên mình tạo 1 Add-Ins để ghép nhiều file Excel thành 1 file duy nhất. Tiện thể chia sẻ cho anh em dùng và góp ý.

    Tạo Add-Ins có cái hay là chỉ cần nạp 1 lần và sử dụng mãi mãi.

    Yêu cầu:
    - Office 2007 trở lên
    - Các File cần ghép có cấu trúc giống hệt nhau
    - Dữ liệu nằm ở Sheet đầu tiên (không phân biệt tên Sheet)
    - Chỉ hoạt động khi bạn chọn từ 2 file trở lên (vì 1 file thì cần gì ghép nữa [IMG]images/smilies/a01.gif[/IMG])

    Mô tả:
    - Chương trình sẽ ghép tất cả các File đã chọn thành 1 File duy nhất tại thư mục chứa các File đang chọn và có tên là "Tong hop ddmmyyyy hhmmss.xlsx"
    - Khi chọn xong các File, chương trình đọc lần lượt từng File. Với File đầu tiên thì sẽ Copy toàn bộ dữ liệu, các file tiếp theo sẽ copy dữ liệu từ hàng thứ 2.
    - Khi xong chương trình tự lưu lại.

    Note: Mình để Open Source để các bạn muốn thì tham khảo và góp ý.
    Do mình muốn gộp các file vào một file đã tạo sẵn nên mình muốn ctrinh vẫn hoạt động trong trường hợp chọn 1 file.
    Bạn có thể giúp mình sửa code được không?

  3. #3
    hoaian Guest
    Trích dẫn Gửi bởi kdang
    Do mình muốn gộp các file vào một file đã tạo sẵn nên mình muốn ctrinh vẫn hoạt động trong trường hợp chọn 1 file.
    Bạn có thể giúp mình sửa code được không?
    Đang không khỏe nhưng cũng cố chọt chọt bàn phím thế này

    Mã nguồn PHP:
    Sub MergeFie() Dim Y, X As Integer, sh As Worksheet, Cursh As Worksheet On Error GoTo ErrHandler Application.ScreenUpdating = False Set Cursh = ActiveSheet Y = Application.GetOpenFilename("Excel Files, *.xls?*", MultiSelect:=True) If TypeName(Y) = "Boolean" Then MsgBox "No Files were selected" GoTo ExitHandler End If X = 1 While X <= UBound(Y) Workbooks.Open Y(X) With ActiveWorkbook For Each sh In .Worksheets If sh.UsedRange.Rows.Count > 1 Then sh.UsedRange.Offset(1).Copy Cursh.[A65536].End(3)(2).PasteSpecial 3 End If Next Application.CutCopyMode = False .Close False End With X = X + 1 WendExitHandler: Application.ScreenUpdating = True Exit SubErrHandler: MsgBox Err.Description Resume ExitHandlerEnd Sub  

  4. #4
    bachlien24 Guest
    Có cao thủ nào giúp em với: em sử dụng code ghép file excel của thinh18tt nhưng nó báo lỗi như bên dưới:

    Sub AUTO_OPEN()
    GhepExcelFile
    End Sub
    Sub GhepExcelFile()
    Dim sFileName As String
    Dim ArrFile() As String
    Dim i As Integer
    Dim DirLog As String
    Dim MaxCol As Long
    Dim MaxRow As Long
    Dim bHeader As Boolean
    Dim OutputFile As String
    bHeader = False
    On Error Resume Next
    Windows("Data.xlsx").Activate
    ActiveWorkbook.Save
    Workbooks("data.xlsx").Close
    On Error GoTo 0
    If ShowOpen(sFileName, , "Excel Files (*.xls;*.xlsx)|*.xls;*.xlsx", , , , , OFN_ALLOWMULTiSELECT Or OFN_EXPLORER) Then
    ArrFile = Split(sFileName, "|")
    DirLog = ArrFile(LBound(ArrFile)) & "\"

    If UBound(ArrFile) > 0 Then
    'OutputFile = "Tong hop " & Format(Now(), "ddmmyyyy hhmmss") & ".xlsx"
    'Workbooks.Add
    'ChDir DirLog
    'ActiveWorkbook.SaveAs Filename:=DirLog & OutputFile
    On Error Resume Next
    Workbooks.Open "D:\chuyen luong\data.xlsx"
    On Error GoTo 0
    For i = LBound(ArrFile) + 1 To UBound(ArrFile)
    Workbooks.Open DirLog & ArrFile(i)
    MaxRow = ActiveSheet.UsedRange.Rows.Count
    MaxCol = ActiveSheet.UsedRange.Columns.Count
    If bHeader = False Then
    Range(Cells(1, 1).Address & ":" & Cells(MaxRow, MaxCol).Address).Select
    bHeader = True
    Else
    Range(Cells(2, 1).Address & ":" & Cells(MaxRow, MaxCol).Address).Select
    End If
    Selection.Copy
    Windows("Data.xlsx").Activate
    MaxRow = ActiveSheet.UsedRange.Rows.Count
    If MaxRow = 1 Then
    Range("A1").Select
    Else
    Range("A" & (MaxRow + 1)).Select
    End If
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Workbooks(ArrFile(i)).Close
    Next i
    Columns("c:f").Delete
    ActiveSheet.Range("$A$1:$B$1000000").RemoveDuplica tes Columns:=Array(1, 2), _
    Header:=xlNo
    Range("A2:A1000000").Select
    On Error Resume Next
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow .Delete
    On Error GoTo 0
    Columns("A:B").Select
    With Selection
    .Font.Bold = False
    .Font.Size = 10
    .Font.Name = "times new roman"
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    'ActiveSheet.Range("a1:b1000000").REMOVEDUPLICATE
    ActiveWorkbook.Save
    Workbooks("data.xlsx").Close
    End If
    End If
    End Sub

  5. #5
    hoathachthao Guest
    Cảm ơn bạn, joint rất hay, bạn có thể sửa code theo tiêu chí này được không (từ ofice 2003-2013).
    1/ Gộp nhiều file excel thành 01 file và mỗi file 1 sheet đã cố định (Không lấy các sheet bên cạnh).
    2/ Tách nhiều sheet của 01 file thành nhiều file, mỗi sheet 01 file.
    Cảm ơn cao thủ trước nhé.

  6. #6
    sonnt Guest
    3/ Gộp nhiều sheet trong 01 file thành 01 sheet duy nhất.

  7. #7
    Ngày tham gia
    Aug 2015
    Bài viết
    0
    Trích dẫn Gửi bởi chuducninh
    Có cao thủ nào giúp em với: em sử dụng code ghép file excel của thinh18tt nhưng nó báo lỗi như bên dưới:

    Sub AUTO_OPEN()
    GhepExcelFile
    End Sub
    Sub GhepExcelFile()
    Dim sFileName As String
    Dim ArrFile() As String
    Dim i As Integer
    Dim DirLog As String
    Dim MaxCol As Long
    Dim MaxRow As Long
    Dim bHeader As Boolean
    Dim OutputFile As String
    bHeader = False
    On Error Resume Next
    Windows("Data.xlsx").Activate
    ActiveWorkbook.Save
    Workbooks("data.xlsx").Close
    On Error GoTo 0
    If ShowOpen(sFileName, , "Excel Files (*.xls;*.xlsx)|*.xls;*.xlsx", , , , , OFN_ALLOWMULTiSELECT Or OFN_EXPLORER) Then
    ArrFile = Split(sFileName, "|")
    DirLog = ArrFile(LBound(ArrFile)) & "\"

    If UBound(ArrFile) > 0 Then
    'OutputFile = "Tong hop " & Format(Now(), "ddmmyyyy hhmmss") & ".xlsx"
    'Workbooks.Add
    'ChDir DirLog
    'ActiveWorkbook.SaveAs Filename:=DirLog & OutputFile
    On Error Resume Next
    Workbooks.Open "D:\chuyen luong\data.xlsx"
    On Error GoTo 0
    For i = LBound(ArrFile) + 1 To UBound(ArrFile)
    Workbooks.Open DirLog & ArrFile(i)
    MaxRow = ActiveSheet.UsedRange.Rows.Count
    MaxCol = ActiveSheet.UsedRange.Columns.Count
    If bHeader = False Then
    Range(Cells(1, 1).Address & ":" & Cells(MaxRow, MaxCol).Address).Select
    bHeader = True
    Else
    Range(Cells(2, 1).Address & ":" & Cells(MaxRow, MaxCol).Address).Select
    End If
    Selection.Copy
    Windows("Data.xlsx").Activate
    MaxRow = ActiveSheet.UsedRange.Rows.Count
    If MaxRow = 1 Then
    Range("A1").Select
    Else
    Range("A" & (MaxRow + 1)).Select
    End If
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Workbooks(ArrFile(i)).Close
    Next i
    Columns("c:f").Delete
    ActiveSheet.Range("$A$1:$B$1000000").RemoveDuplica tes Columns:=Array(1, 2), _
    Header:=xlNo
    Range("A2:A1000000").Select
    On Error Resume Next
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow .Delete
    On Error GoTo 0
    Columns("A:B").Select
    With Selection
    .Font.Bold = False
    .Font.Size = 10
    .Font.Name = "times new roman"
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    'ActiveSheet.Range("a1:b1000000").REMOVEDUPLICATE
    ActiveWorkbook.Save
    Workbooks("data.xlsx").Close
    End If
    End If
    End Sub
    Bạn dùng file gốc của bạn thinh18tt nhé. code trên là file Jointdata mà mình đã sửa code để dùng gộp các file mình cần làm.

  8. #8
    hoanganha1q2 Guest
    Cám ơn tác giả rất nhiều. Cho mình hỏi thêm, nếu mình muốn join từ sheet 2 (ko phải join sheet 1) thì sao? VÌ hàng tháng mình cần join khoảng 30 file, mỗi file có 5 sheet, nhưng mình chỉ cần join sheet thứ hai mà thôi.
    Tks again!

  9. #9
    mantrangchu Guest
    Trích dẫn Gửi bởi dexem
    Cám ơn tác giả rất nhiều. Cho mình hỏi thêm, nếu mình muốn join từ sheet 2 (ko phải join sheet 1) thì sao? VÌ hàng tháng mình cần join khoảng 30 file, mỗi file có 5 sheet, nhưng mình chỉ cần join sheet thứ hai mà thôi.
    Tks again!
    sheet 2 ở đây là:
    1/ sheet.name = "sheet 2" (Tức là cái tên của worksheet mà bạn nhìn thấy ở tab sheet)
    2/ (Name) = Sheet 2 (Properties của worksheet trong VBA)

  10. #10
    thanhhoabn29 Guest
    Cám ơn tác giả, mình đã joint thành công sheet 2.

Trang 1 của 2 12 CuốiCuối

Quyền viết bài

  • Bạn Không thể gửi Chủ đề mới
  • Bạn Không thể Gửi trả lời
  • Bạn Không thể Gửi file đính kèm
  • Bạn Không thể Sửa bài viết của mình
  •