Nhờ giúp macro tổng hợp dữ liệu , lấy cả tên sheet, tên file

Liên hệ QC

phamhau299

Thành viên mới
Tham gia
10/3/11
Bài viết
40
Được thích
1
Mình có các file dữ liệu và 1 file tổng hợp
Trong file “tổng hợp”, khi nhấn macro, sẽ được yêu cầu chọn đường dẫn đến các file dữ liệu. Khi chọn xong sẽ tự động tổng hợp lại
Và sẽ tổng hợp các cột sau: Mã Nguyên vật liệu, Vị trí, Tổng, Tên sheet, Tên file

Nhờ ace giúp đỡ
 

File đính kèm

  • TONG HOP NVL.xlsx
    12.7 KB · Đọc: 17
  • KIEM KE LINE B.xls
    42 KB · Đọc: 17
  • KIEM KE LINE A.xls
    51 KB · Đọc: 17
Mình có các file dữ liệu và 1 file tổng hợp
Trong file “tổng hợp”, khi nhấn macro, sẽ được yêu cầu chọn đường dẫn đến các file dữ liệu. Khi chọn xong sẽ tự động tổng hợp lại
Và sẽ tổng hợp các cột sau: Mã Nguyên vật liệu, Vị trí, Tổng, Tên sheet, Tên file

Nhờ ace giúp đỡ
Bạn tham khảo code sau của anh @batman1 và chỉnh sửa cho phù hợp nhé:
Mã:
Sub GopFiles()
  
    Dim x As Integer, directory As String, fileName As String, wb As Workbook
    Dim ws As Worksheet, lc As Long, lr As Long, lr2 As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    directory = (ThisWorkbook.Path & "\")
    fileName = Dir(directory & "*.xlsx")
    Set ws = ThisWorkbook.Sheets(1)
    Do While fileName <> ""
        Set wb = Workbooks.Open(directory & fileName)
        If x = 0 Then
            wb.Sheets(1).UsedRange.Copy ws.Range("A1")
                lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                lr = ws.UsedRange.Rows.Count
            If ws.Cells(1, lc).Value <> "Tên Sheet" Then
                ws.Cells(1, lc + 1).Value = "Tên Sheet"
                ws.Cells(2, lc + 1).Resize(lr - 1).Value = ActiveSheet.Name
            End If
            If ws.Cells(1, lc).Value <> "Tên file" Then
                ws.Cells(1, lc + 2).Value = "Tên file"
                ws.Cells(2, lc + 2).Resize(lr - 1).Value = fileName
            End If
        Else
            lr = ws.UsedRange.Rows.Count
            wb.Sheets(1).UsedRange.Offset(1).Copy ws.Range("A" & lr + 1)
            lr2 = wb.Sheets(1).UsedRange.Rows.Count
            lc = ws.Cells(lr + 1, ws.Columns.Count).End(xlToLeft).Column
            ws.Cells(lr + 1, lc + 1).Resize(lr2 - 1).Value = ActiveSheet.Name
            ws.Cells(lr + 1, lc + 2).Resize(lr2 - 1).Value = fileName
        End If
        wb.Close False
        x = x + 1
        fileName = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub
 

File đính kèm

  • Gop files.xlsm
    19.3 KB · Đọc: 17
Lần chỉnh sửa cuối:
Upvote 0
Bạn tham khảo code sau của anh @batman1 và chỉnh sửa cho phù hợp nhé:
Mã:
Sub GopFiles()
 
    Dim x As Integer, directory As String, fileName As String, wb As Workbook
    Dim ws As Worksheet, lc As Long, lr As Long, lr2 As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    directory = (ThisWorkbook.Path & "\")
    fileName = Dir(directory & "*.xlsx")
    Set ws = ThisWorkbook.Sheets(1)
    Do While fileName <> ""
        Set wb = Workbooks.Open(directory & fileName)
        If x = 0 Then
            wb.Sheets(1).UsedRange.Copy ws.Range("A1")
                lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                lr = ws.UsedRange.Rows.Count
            If ws.Cells(1, lc).Value <> "Tên Sheet" Then
                ws.Cells(1, lc + 1).Value = "Tên Sheet"
                ws.Cells(2, lc + 1).Resize(lr - 1).Value = ActiveSheet.Name
            End If
            If ws.Cells(1, lc).Value <> "Tên file" Then
                ws.Cells(1, lc + 2).Value = "Tên file"
                ws.Cells(2, lc + 2).Resize(lr - 1).Value = fileName
            End If
        Else
            lr = ws.UsedRange.Rows.Count
            wb.Sheets(1).UsedRange.Offset(1).Copy ws.Range("A" & lr + 1)
            lr2 = wb.Sheets(1).UsedRange.Rows.Count
            lc = ws.Cells(lr + 1, ws.Columns.Count).End(xlToLeft).Column
            ws.Cells(lr + 1, lc + 1).Resize(lr2 - 1).Value = ActiveSheet.Name
            ws.Cells(lr + 1, lc + 2).Resize(lr2 - 1).Value = fileName
        End If
        wb.Close False
        x = x + 1
        fileName = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Mình gà code bạn ơi
Macro trên mình phải đưa file dữ liệu và file tổng hợp về chung folder.
Mình muốn hiện hộp thoại yêu cầu chon file rồi chạy
Mong bạn giúp đỡ
 
Upvote 0
Mình gà code bạn ơi
Macro trên mình phải đưa file dữ liệu và file tổng hợp về chung folder.
Mình muốn hiện hộp thoại yêu cầu chon file rồi chạy
Mong bạn giúp đỡ
Tham khảo code này để lấy đường dẫn folder (tự ghép vào sử dụng, còn không biết code thì phải đọc và học thôi)
Mã:
Sub SelectFolder()
Dim sFolder As String
    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sFolder = .SelectedItems(1)
        End If
    End With
    
    If sFolder <> "" Then ' if a file was chosen
        ' *********************
        ' put your code in here
        ' *********************
    End If
End Sub
 
Upvote 0
Mình gà code bạn ơi
Macro trên mình phải đưa file dữ liệu và file tổng hợp về chung folder.
Mình muốn hiện hộp thoại yêu cầu chon file rồi chạy
Mong bạn giúp đỡ
Bạn dùng đỡ code củ chuối như đính kèm thử nhé,.
 

File đính kèm

  • TONG HOP NVL_v2.xlsb
    31.1 KB · Đọc: 11
Upvote 0
cho mình hỏi sao mỗi lần chạy chọn folder xong rồi phải chọn cả sheet nữa mới chạy được, mỗi 1 lần là chỉ được chọn 1 sheet. Dữ liệu của mình rất nhiều file. trong 1 file có nhiều sheet
Bạn thay toàn bộ code trong file bài #5 bằng code sau rồi chạy lại nhé:
PHP:
Option Explicit
Sub Main()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(fileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Range("H6:H10000").Value = Left(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 1)
                    wksCurSheet.Range("I6:I10000").Value = wksCurSheet.Name
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
          
            Call Combine         
        End If
    End If 
End Sub
Private Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Sheets(2).Activate
Range("A6").EntireRow.Copy Destination:=Sheets(1).Range("A4")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A6").Select
Selection.CurrentRegion.Select
Selection.Value = Selection.Value
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Call transfer
End Sub

Private Sub transfer()
Sheet1.Select
Dim eRow As Long, ws As Worksheet
eRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1
With Sheet1
    .Range("A4").EntireRow.Delete
    .Range("B4:C" & eRow).Cut Destination:=Range("A4")
    .Range("G4:G" & eRow).Cut Destination:=Range("C4")
    .Range("H4:H" & eRow).Cut Destination:=Range("E4")
    .Range("I4:I" & eRow).Cut Destination:=Range("D4")
    Columns("F:ZZ").EntireColumn.Delete
    Columns("A:F").EntireColumn.AutoFit
End With
    For Each ws In Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ws.Delete
        End If
    Next ws
    MsgBox "Done", Title:="Notice:"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thay toàn bộ code trong file bài #5 bằng code sau rồi chạy lại nhé:
PHP:
Option Explicit
Sub Main()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(fileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Range("H6:H10000").Value = Left(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 1)
                    wksCurSheet.Range("I6:I10000").Value = wksCurSheet.Name
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
         
            Call Combine        
        End If
    End If
End Sub
Private Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Sheets(2).Activate
Range("A6").EntireRow.Copy Destination:=Sheets(1).Range("A4")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A6").Select
Selection.CurrentRegion.Select
Selection.Value = Selection.Value
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Call transfer
End Sub

Private Sub transfer()
Sheet1.Select
Dim eRow As Long, ws As Worksheet
eRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1
With Sheet1
    .Range("A4").EntireRow.Delete
    .Range("B4:C" & eRow).Cut Destination:=Range("A4")
    .Range("G4:G" & eRow).Cut Destination:=Range("C4")
    .Range("H4:H" & eRow).Cut Destination:=Range("E4")
    .Range("I4:I" & eRow).Cut Destination:=Range("D4")
    Columns("F:ZZ").EntireColumn.Delete
    Columns("A:F").EntireColumn.AutoFit
End With
    For Each ws In Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ws.Delete
        End If
    Next ws
    MsgBox "Done", Title:="Notice:"
End Sub

Cảm ơn bạn nhiều nhé. Code trên mình đã chạy được.
Mình có vấn đề này nhờ bạn giúp thêm:
Có một số file dữ liệu không đồng nhất vị trí các cột nên mình đã link các cột ra phía sau để đồng nhất các file
Mã NVL (cột AA)
Vị trí (Cột AB)
Tổng (cột AC)
Vậy mình cần sửa code lại như thế nào ? (file Tổng hợp vẫn giữ nguyên cấu trúc)
Hoặc có thể dựa vào text : "MÃ NGUYÊN VẬT LIỆU" , "VỊ TRÍ", "TỔNG" có thể bắt được dữ liệu được không (cho dù nó ở vị trí nào cũng được) ?
 

File đính kèm

  • KIEM KE LINE A NEW.xls
    43.5 KB · Đọc: 8
Upvote 0
Cảm ơn bạn nhiều nhé. Code trên mình đã chạy được.
Mình có vấn đề này nhờ bạn giúp thêm:
Có một số file dữ liệu không đồng nhất vị trí các cột nên mình đã link các cột ra phía sau để đồng nhất các file
Mã NVL (cột AA)
Vị trí (Cột AB)
Tổng (cột AC)
Vậy mình cần sửa code lại như thế nào ? (file Tổng hợp vẫn giữ nguyên cấu trúc)
Hoặc có thể dựa vào text : "MÃ NGUYÊN VẬT LIỆU" , "VỊ TRÍ", "TỔNG" có thể bắt được dữ liệu được không (cho dù nó ở vị trí nào cũng được) ?
Bạn chỉ cần giữ đúng vị trí 3 cột sau là được:
Rich (BB code):
Cột B = MÃ NGUYÊN VẬT LIỆU
Cột C = VỊ TRÍ
Cột G = TỔNG

Các cột khác bạn thay đổi thế nào cũng được mà không ảnh hướng đến file tổng hợp !
 
Upvote 0
Bạn chỉ cần giữ đúng vị trí 3 cột sau là được:
Rich (BB code):
Cột B = MÃ NGUYÊN VẬT LIỆU
Cột C = VỊ TRÍ
Cột G = TỔNG

Các cột khác bạn thay đổi thế nào cũng được mà không ảnh hướng đến file tổng hợp !

Ý mình là dữ liệu các bộ phận gửi cho mình có thể không đúng vị trí 3 cột, mỗi bộ phận gửi 1 kiểu :
Có thể là:
Cột M = MÃ NGUYÊN VẬT LIỆU
Cột N= VỊ TRÍ
Cột O= TỔNG

Nên mình muốn thống nhất tất cả các file bằng cách link ra phía sau:
Cột AA = Cột B (= Cột M...) MÃ NGUYÊN VẬT LIỆU
Cột AB= Cột C (= Côt N...) VỊ TRÍ
Cột AC= Cột G (= Cột O...) TỔNG
Nên không biết sửa lại code cho đúng cột AA, AB, AC. Hoặc có thể code dựa vào tiêu đề mà chạy được không? nên nhờ bạn giúp đỡ
 

File đính kèm

  • KIEM KE LINE A NEW.xls
    44 KB · Đọc: 6
Lần chỉnh sửa cuối:
Upvote 0
Ý mình là dữ liệu các bộ phận gửi cho mình có thể không đúng vị trí 3 cột, mỗi bộ phận gửi 1 kiểu :
Có thể là:
Cột M = MÃ NGUYÊN VẬT LIỆU
Cột N= VỊ TRÍ
Cột O= TỔNG

Nên mình muốn thống nhất tất cả các file bằng cách link ra phía sau:
Cột AA = Cột B (= Cột M...) MÃ NGUYÊN VẬT LIỆU
Cột AB= Cột C (= Côt N...) VỊ TRÍ
Cột AC= Cột G (= Cột O...) TỔNG
Nên không biết sửa lại code cho đúng cột AA, AB, AC. Hoặc có thể code dựa vào tiêu đề mà chạy được không? nên nhờ bạn giúp đỡ
Như vậy, mình hiểu là bạn cần lấy toàn bộ dữ liệu tại các cột phía dưới để gộp sang file tổng ?
Cột AA = Cột B (= Cột M...) MÃ NGUYÊN VẬT LIỆU
Cột AB= Cột C (= Côt N...) VỊ TRÍ
Cột AC= Cột G (= Cột O...) TỔNG
Nếu đúng thế, bạn sửa toàn bộ code bài #7 thay bằng code sau và chạy lại kiểm tra nhé;
Mã:
Option Explicit

Sub Main()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim eRow As Long

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(fileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Range("AD6:AD10000").Value = Left(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 1)
                    wksCurSheet.Range("AE6:AE10000").Value = wksCurSheet.Name
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
           
            Call Combine
        End If
    End If
   
End Sub
Private Sub Combine()
Dim j As Integer
On Error Resume Next
Sheets(1).Select
Sheets(2).Activate
Range("A6").EntireRow.Copy Destination:=Sheets(1).Range("A4")
For j = 2 To Sheets.Count
Sheets(j).Activate
Range("AA6").Select
Selection.CurrentRegion.Select
Selection.Value = Selection.Value
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Call transfer
End Sub

Private Sub transfer()
Sheet1.Select
Dim eRow As Long
Dim ws As Worksheet
eRow = Sheet1.Range("D" & Rows.Count).End(xlUp).Row + 1
With Sheet1
    .Range("A4").EntireRow.Delete
    .Range("A5:E" & eRow).AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
    .Range("A5:E" & eRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Range("A3:F3").AutoFilter  
    Columns("F:ZZ").EntireColumn.Delete
    Columns("A:F").EntireColumn.AutoFit
End With
    For Each ws In Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ws.Delete
        End If
    Next ws
    MsgBox "Done", Title:="Notice:"
End Sub
 
Upvote 0
Như vậy, mình hiểu là bạn cần lấy toàn bộ dữ liệu tại các cột phía dưới để gộp sang file tổng ?

Nếu đúng thế, bạn sửa toàn bộ code bài #7 thay bằng code sau và chạy lại kiểm tra nhé;
Mã:
Option Explicit

Sub Main()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim eRow As Long

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(fileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Range("AD6:AD10000").Value = Left(wbkSrcBook.Name, InStrRev(wbkSrcBook.Name, ".") - 1)
                    wksCurSheet.Range("AE6:AE10000").Value = wksCurSheet.Name
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
          
            Call Combine
        End If
    End If
  
End Sub
Private Sub Combine()
Dim j As Integer
On Error Resume Next
Sheets(1).Select
Sheets(2).Activate
Range("A6").EntireRow.Copy Destination:=Sheets(1).Range("A4")
For j = 2 To Sheets.Count
Sheets(j).Activate
Range("AA6").Select
Selection.CurrentRegion.Select
Selection.Value = Selection.Value
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Call transfer
End Sub

Private Sub transfer()
Sheet1.Select
Dim eRow As Long
Dim ws As Worksheet
eRow = Sheet1.Range("D" & Rows.Count).End(xlUp).Row + 1
With Sheet1
    .Range("A4").EntireRow.Delete
    .Range("A5:E" & eRow).AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
    .Range("A5:E" & eRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Range("A3:F3").AutoFilter 
    Columns("F:ZZ").EntireColumn.Delete
    Columns("A:F").EntireColumn.AutoFit
End With
    For Each ws In Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ws.Delete
        End If
    Next ws
    MsgBox "Done", Title:="Notice:"
End Sub

Cảm ơn bạn đã giúp đỡ nhé
 
Upvote 0
Web KT
Back
Top Bottom