Tổng hợp dữ liệu theo nhóm (từ nhiều file)? (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Hoàng Nhật Phương

Thành viên gắn bó
Tham gia
5/11/15
Bài viết
1,895
Được thích
1,219
Xin chào tất cả các bạn,

Như tiêu Oanh Thơ đã nêu,vấn đề chi tiết xin được nêu cụ thể trong tập tin.
Nhờ các bạn giúp đỡ cho tôi trường hợp trong tập tin gửi kèm ạ.
 

File đính kèm

Xin chào tất cả các bạn,

Như tiêu Oanh Thơ đã nêu,vấn đề chi tiết xin được nêu cụ thể trong tập tin.
Nhờ các bạn giúp đỡ cho tôi trường hợp trong tập tin gửi kèm ạ.
Bạn thử dùng code sau xem đúng chưa nhé!
Mã:
Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim I As Long, K As Long, lC As Long
    
    Sheet1.Range("B7:G65000").ClearContents
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If
        
        Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            For Each Ws In Wk.Sheets
                With Ws
                    WsName = .Name
                    .Columns("A:G").Delete: .Rows("8:9").Delete
                    lC = .Range("A7").End(xlToRight).Column
                    sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                    For I = 2 To UBound(sArr, 2)
                        K = K + 1
                        dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I)
                        dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I)
                    Next I
                End With
            Next Ws
            Wk.Close False
        Next Item
        Application.DisplayAlerts = False
    End With
    Sheet1.Range("B7").Resize(K, 6) = dArr
    MsgBox "Done", vbInformation, "GPE"
End Sub
 
Upvote 0
Bạn thử dùng code sau xem đúng chưa nhé!
Mã:
Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim I As Long, K As Long, lC As Long
 
    Sheet1.Range("B7:G65000").ClearContents
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If
    
        Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            For Each Ws In Wk.Sheets
                With Ws
                    WsName = .Name
                    .Columns("A:G").Delete: .Rows("8:9").Delete
                    lC = .Range("A7").End(xlToRight).Column
                    sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                    For I = 2 To UBound(sArr, 2)
                        K = K + 1
                        dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I)
                        dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I)
                    Next I
                End With
            Next Ws
            Wk.Close False
        Next Item
        Application.DisplayAlerts = False
    End With
    Sheet1.Range("B7").Resize(K, 6) = dArr
    MsgBox "Done", vbInformation, "GPE"
End Sub
Bạn thử dùng code sau xem đúng chưa nhé!
Mã:
Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim I As Long, K As Long, lC As Long
 
    Sheet1.Range("B7:G65000").ClearContents
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If
     
        Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            For Each Ws In Wk.Sheets
                With Ws
                    WsName = .Name
                    .Columns("A:G").Delete: .Rows("8:9").Delete
                    lC = .Range("A7").End(xlToRight).Column
                    sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                    For I = 2 To UBound(sArr, 2)
                        K = K + 1
                        dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I)
                        dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I)
                    Next I
                End With
            Next Ws
            Wk.Close False
        Next Item
        Application.DisplayAlerts = False
    End With
    Sheet1.Range("B7").Resize(K, 6) = dArr
    MsgBox "Done", vbInformation, "GPE"
End Sub

Xin chào vanthinh3101,
Code của bạn lấy dữ liệu rất đúng với những gì tôi mong muốn rồi.
Trong quá trình áp dụng nếu có vấn đề gì xảy ra mong bạn tiếp tục hỗ trợ.
Xin cảm ơn bạn rất nhiều.
 
Upvote 0
Xin chào vanthinh3101,

Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.

Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.

Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
 

File đính kèm

Upvote 0
Xin chào vanthinh3101,

Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.

Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.

Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Bạn cho mình hỏi:
- Có khoảng bao nhiêu file cần tổng hợp.
- Ngoài các sheet cần tổng hợp, các sheet còn lại đều có tên là sheet1, sheet2, sheet... hay tên khác.
 
Upvote 0
Bạn cho mình hỏi:
- Có khoảng bao nhiêu file cần tổng hợp.
- Ngoài các sheet cần tổng hợp, các sheet còn lại đều có tên là sheet1, sheet2, sheet... hay tên khác.

Xin chào vanthinh3101,

Cảm ơn bạn đã giúp đỡ.
Có 16 tập tin cần tổng hợp, trong mỗi tập tin sheet cần tổng hợp được ghi chính xác ở sheet "Nguon" còn lại các sheet không liệt kê thì cũng rất nhiều không cụ thể là sheet1 hay sheet2 mà linh tinh bạn ạ.

Nhờ vanthinh3101 và các bạn xem giúp.
 
Upvote 0
Xin chào vanthinh3101,

Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.

Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.

Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Bạn thử code này.
Lưu ý: Đứng ở sheet tên gì thì tổng hợp dữ liệu ở thư mục có tên đó; Thư mục chứa file cần tổng hợp và file chứa code này ở chung trong một thư mục mẹ.
PHP:
Const StartCll As String = "C3"
Const FirstRow As Long = 7
Const FirstCol As Long = 9
Sub CallMe()
Dim WriteToSh As Worksheet, TmpSh As Worksheet, sFileName As String, FileNameCll As Range, ShNameCll As Range
Dim sFolder As String
Application.ScreenUpdating = False
Set WriteToSh = ActiveSheet
Set TmpSh = AddTmpSh()
Set FileNameCll = Worksheets("Nguon").Range(StartCll)
sFolder = ThisWorkbook.Path & "\" & WriteToSh.Name
WriteToSh.Range("B" & FirstRow & ":G" & &H100000).ClearContents
Do Until FileNameCll.Value = ""
    sFileName = FileNameCll.Value
    If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
        Set ShNameCll = FileNameCll.Offset(, 1)
        Do Until ShNameCll.Value = ""
            If EnterFormula(TmpSh, sFolder, sFileName, ShNameCll.Value) Then _
                WriteData TmpSh, WriteToSh, ShNameCll.Value
            Set ShNameCll = ShNameCll.Offset(, 1)
        Loop
    End If
    Set FileNameCll = FileNameCll.Offset(1)
Loop
DelTmpSh TmpSh
WriteToSh.Activate
Application.ScreenUpdating = True
End Sub
Private Sub WriteData(ByRef TmpSh As Worksheet, ByRef WriteToSh As Worksheet, ByVal CustomerName As String)
Dim NextRow As Long, ColsCount As Long
ColsCount = TmpSh.Cells(6, 1).Value - 1
If ColsCount = 0 Then Exit Sub
NextRow = WriteToSh.Cells(&H100000, 2).End(xlUp).Row + 1
If NextRow < FirstRow Then NextRow = FirstRow
With WriteToSh.Cells(NextRow, 2).Resize(ColsCount)
    .Value = CustomerName
    .Offset(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(1, FirstCol).Resize(, ColsCount))
    .Offset(, 4).Resize(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(4, FirstCol).Resize(2, ColsCount))
End With
End Sub
Private Function AddTmpSh() As Worksheet
Set AddTmpSh = Worksheets.Add
AddTmpSh.Cells(6, 1).FormulaR1C1 = "=MATCH(0,R1C" & FirstCol & ":R1C[-1],0)"
End Function
Private Sub DelTmpSh(ByVal TmpSh As Worksheet)
Application.DisplayAlerts = False
TmpSh.Delete
Application.DisplayAlerts = True
End Sub
Private Function EnterFormula(ByRef TmpSh As Worksheet, ByVal sFolder As String, ByVal sFileName As String, ByVal sSheetName As String) As Boolean
On Error GoTo Err_
TmpSh.Rows("1:5").FormulaArray = "='" & sFolder & "\[" & sFileName & "]" & sSheetName & "'!7:11"
EnterFormula = True
Err_:
End Function
 
Upvote 0
Bạn thử code này.
Lưu ý: Đứng ở sheet tên gì thì tổng hợp dữ liệu ở thư mục có tên đó; Thư mục chứa file cần tổng hợp và file chứa code này ở chung trong một thư mục mẹ.
PHP:
Const StartCll As String = "C3"
Const FirstRow As Long = 7
Const FirstCol As Long = 9
Sub CallMe()
Dim WriteToSh As Worksheet, TmpSh As Worksheet, sFileName As String, FileNameCll As Range, ShNameCll As Range
Dim sFolder As String
Application.ScreenUpdating = False
Set WriteToSh = ActiveSheet
Set TmpSh = AddTmpSh()
Set FileNameCll = Worksheets("Nguon").Range(StartCll)
sFolder = ThisWorkbook.Path & "\" & WriteToSh.Name
WriteToSh.Range("B" & FirstRow & ":G" & &H100000).ClearContents
Do Until FileNameCll.Value = ""
    sFileName = FileNameCll.Value
    If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
        Set ShNameCll = FileNameCll.Offset(, 1)
        Do Until ShNameCll.Value = ""
            If EnterFormula(TmpSh, sFolder, sFileName, ShNameCll.Value) Then _
                WriteData TmpSh, WriteToSh, ShNameCll.Value
            Set ShNameCll = ShNameCll.Offset(, 1)
        Loop
    End If
    Set FileNameCll = FileNameCll.Offset(1)
Loop
DelTmpSh TmpSh
WriteToSh.Activate
Application.ScreenUpdating = True
End Sub
Private Sub WriteData(ByRef TmpSh As Worksheet, ByRef WriteToSh As Worksheet, ByVal CustomerName As String)
Dim NextRow As Long, ColsCount As Long
ColsCount = TmpSh.Cells(6, 1).Value - 1
If ColsCount = 0 Then Exit Sub
NextRow = WriteToSh.Cells(&H100000, 2).End(xlUp).Row + 1
If NextRow < FirstRow Then NextRow = FirstRow
With WriteToSh.Cells(NextRow, 2).Resize(ColsCount)
    .Value = CustomerName
    .Offset(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(1, FirstCol).Resize(, ColsCount))
    .Offset(, 4).Resize(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(4, FirstCol).Resize(2, ColsCount))
End With
End Sub
Private Function AddTmpSh() As Worksheet
Set AddTmpSh = Worksheets.Add
AddTmpSh.Cells(6, 1).FormulaR1C1 = "=MATCH(0,R1C" & FirstCol & ":R1C[-1],0)"
End Function
Private Sub DelTmpSh(ByVal TmpSh As Worksheet)
Application.DisplayAlerts = False
TmpSh.Delete
Application.DisplayAlerts = True
End Sub
Private Function EnterFormula(ByRef TmpSh As Worksheet, ByVal sFolder As String, ByVal sFileName As String, ByVal sSheetName As String) As Boolean
On Error GoTo Err_
TmpSh.Rows("1:5").FormulaArray = "='" & sFolder & "\[" & sFileName & "]" & sSheetName & "'!7:11"
EnterFormula = True
Err_:
End Function

Xin chào huuthang_bd,
Oanh Thơ cảm ơn Anh rất nhiều,

Không hiểu nguyên nhân gì mà Oanh Thơ copy code của Anh vào cửa sổ code thì báo lỗi nhiều dòng đỏ và các từ khóa không hiển thị màu xanh, phiền Anh có thể gửi cho Oanh Thơ xin tập tin đính kèm được không ạ.

hic.jpg
 
Upvote 0
Xin chào huuthang_bd,
Oanh Thơ cảm ơn Anh rất nhiều,

Không hiểu nguyên nhân gì mà Oanh Thơ copy code của Anh vào cửa sổ code thì báo lỗi nhiều dòng đỏ và các từ khóa không hiển thị màu xanh, phiền Anh có thể gửi cho Oanh Thơ xin tập tin đính kèm được không ạ.
Tôi cũng không biết.
Đây là file đã có code.
 

File đính kèm

Upvote 0
Tôi cũng không biết.
Đây là file đã có code.


Xin chào huuthang_bd,
Tập tin Anh gửi code chạy rất đúng ý của Oanh Thơ rồi, hihi

Code của Anh ,Oanh Thơ kết nhất 2 dòng, và Oanh Thơ chỉ hiểu được đúng 2 dòng này thôi ạ :)) vì đó là mong muốn của Oanh Thơ ngay từ ban đầu định hỏi nhưng cảm thấy rất khó giải thích nên chưa nêu ra được:
...
sFolder = ThisWorkbook.Path & "\" & WriteToSh.Name
...
Set ShNameCll = FileNameCll.Offset(, 1)
...


Đúng là những cái tên thân quen thực sự hiểu Oanh Thơ đang muốn gì :))

Trong quá trình sử dụng nếu có vấn đề gì phát sinh rất mong Anh và các bạn tiếp tục hỗ trợ.

Một lần cảm ơn anh huuthang_bd và Diễn đàn,
Chúc cả nhà cuối tuần vui vẻ ^^
 
Upvote 0
Xin chào vanthinh3101,

Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.

Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.

Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Mình đã sửa lại code, bạn thử xem thế nào, có gì báo mình.
Khi tổng hợp trên máy của mình thì mất hơn 10s.
Mã:
Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim Names(1 To 1000), Rng(), TestFile, TestSheet
    Dim A As Long, B As Long, C As Long
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim i As Long, k As Long, lC As Long, T
    
    T = Timer
    Sheet1.Range("B7:G65000").ClearContents
    
    With Sheet3
        Rng = .Range("C3:N18").Value
        For A = 1 To UBound(Rng, 1)
            For B = 1 To UBound(Rng, 2)
                If Len(Rng(A, B)) Then Names(C + 1) = Rng(A, B): C = C + 1
            Next B
        Next A
    End With
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            TestFile = Filter(Names, Wk.Name, True)
            If UBound(TestFile) <> 0 Then
                Wk.Close False
            Else
                For Each Ws In Wk.Sheets
                    TestSheet = Filter(Names, Ws.Name, True)
                    If UBound(TestSheet) >= 0 Then
                        With Ws
                            WsName = .Name
                            .Columns("A:G").Delete: .Rows("8:9").Delete
                            lC = .Range("A7").End(xlToRight).Column
                            sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                            For i = 2 To UBound(sArr, 2)
                                k = k + 1
                                dArr(k, 1) = WsName: dArr(k, 3) = sArr(1, i)
                                dArr(k, 5) = sArr(2, i): dArr(k, 6) = sArr(3, i)
                            Next i
                        End With
                    End If
                Next Ws
                Wk.Close False
            End If
        Next Item
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End With
    Sheet1.Range("B7").Resize(k, 6) = dArr
    MsgBox "Done in " & Int(Timer - T) & "s.", vbInformation, "GPE"
End Sub
 
Upvote 0
Mình đã sửa lại code, bạn thử xem thế nào, có gì báo mình.
Khi tổng hợp trên máy của mình thì mất hơn 10s.
Mã:
Sub SummaryData()
    Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
    Dim Names(1 To 1000), Rng(), TestFile, TestSheet
    Dim A As Long, B As Long, C As Long
    Dim sArr(), dArr(1 To 10000, 1 To 6)
    Dim i As Long, k As Long, lC As Long, T
  
    T = Timer
    Sheet1.Range("B7:G65000").ClearContents
  
    With Sheet3
        Rng = .Range("C3:N18").Value
        For A = 1 To UBound(Rng, 1)
            For B = 1 To UBound(Rng, 2)
                If Len(Rng(A, B)) Then Names(C + 1) = Rng(A, B): C = C + 1
            Next B
        Next A
    End With
  
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls*", 1
        If Not .Show = -1 Then
            MsgBox "Ban chua chon file", vbCritical, "GPE"
            Exit Sub
        End If
      
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each Item In .SelectedItems
            Set Wk = Workbooks.Open(Item)
            TestFile = Filter(Names, Wk.Name, True)
            If UBound(TestFile) <> 0 Then
                Wk.Close False
            Else
                For Each Ws In Wk.Sheets
                    TestSheet = Filter(Names, Ws.Name, True)
                    If UBound(TestSheet) >= 0 Then
                        With Ws
                            WsName = .Name
                            .Columns("A:G").Delete: .Rows("8:9").Delete
                            lC = .Range("A7").End(xlToRight).Column
                            sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
                            For i = 2 To UBound(sArr, 2)
                                k = k + 1
                                dArr(k, 1) = WsName: dArr(k, 3) = sArr(1, i)
                                dArr(k, 5) = sArr(2, i): dArr(k, 6) = sArr(3, i)
                            Next i
                        End With
                    End If
                Next Ws
                Wk.Close False
            End If
        Next Item
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End With
    Sheet1.Range("B7").Resize(k, 6) = dArr
    MsgBox "Done in " & Int(Timer - T) & "s.", vbInformation, "GPE"
End Sub

Xin chào vanthinh3101,

Rất xin lỗi bạn vì thời gian qua Oanh Thơ bận chút việc riêng nên không Olnine được.
Xin cảm ơn bạn rất nhiều, Oanh Thơ đã thử code trên code của bạn với file mẫu gửi lên thì đúng là rất nhanh,khoảng 1s. Bạn thao tác hơn 10s có thể là vì code đo thời gian của bạn đặt trước câu lệnh,
....
With Application.FileDialog(msoFileDialogFilePicker)
....
Vì vậy mà thời gian test còn phụ thuộc vào cả thao tác của mỗi người.
Oanh Thơ ngĩ như thế này thì hợp lý hơn ạ ?
....
If Not .Show = -1 Then
MsgBox "Ban chua chon file", vbCritical, "GPE"
Exit Sub
End If
T = Timer
....

Nhưng với file thực thì tốc độ code của bạn có phần chậm hơn so với cách của anh huuthang, theo kiến thức kém cỏi của mình Oanh Thơ cho rằng có thể nguyên nhân coed của bạn chậm là do:
Các tập tin nguồn thực tế của Oanh Thơ nặng, nhiều sheet, nhiều dữ liệu.
Code của bạn là yêu cầu phải mở trực tiếp các tập tin nguồn lên, còn code của anh huuthang không cần phải mở các tập tin nguồn mà sử dụng công thức mảng để lấy dữ liệu trực tiếp từ các tập tin nguồn.

Hic, nếu có điểm nào nhận xét không phải mong bạn và mọi người bỏ qua và góp ý thêm ạ.
Trân trọng cảm ơn,
 
Upvote 0
Xin chào vanthinh3101,

Rất xin lỗi bạn vì thời gian qua Oanh Thơ bận chút việc riêng nên không Olnine được.
Xin cảm ơn bạn rất nhiều, Oanh Thơ đã thử code trên code của bạn với file mẫu gửi lên thì đúng là rất nhanh,khoảng 1s. Bạn thao tác hơn 10s có thể là vì code đo thời gian của bạn đặt trước câu lệnh,
....
With Application.FileDialog(msoFileDialogFilePicker)
....
Vì vậy mà thời gian test còn phụ thuộc vào cả thao tác của mỗi người.
Oanh Thơ ngĩ như thế này thì hợp lý hơn ạ ?
....
If Not .Show = -1 Then
MsgBox "Ban chua chon file", vbCritical, "GPE"
Exit Sub
End If
T = Timer
....

Nhưng với file thực thì tốc độ code của bạn có phần chậm hơn so với cách của anh huuthang, theo kiến thức kém cỏi của mình Oanh Thơ cho rằng có thể nguyên nhân coed của bạn chậm là do:
Các tập tin nguồn thực tế của Oanh Thơ nặng, nhiều sheet, nhiều dữ liệu.
Code của bạn là yêu cầu phải mở trực tiếp các tập tin nguồn lên, còn code của anh huuthang không cần phải mở các tập tin nguồn mà sử dụng công thức mảng để lấy dữ liệu trực tiếp từ các tập tin nguồn.

Hic, nếu có điểm nào nhận xét không phải mong bạn và mọi người bỏ qua và góp ý thêm ạ.
Trân trọng cảm ơn,
Không có gì đâu bạn ah.
Mình làm trên cơ sở code cũ và yêu cầu thêm mới của bạn.
Quan trọng nhất là đúng.
Đối với VBA thì khả năng của mình cũng chỉ là dạng sơ cấp thôi
 
Upvote 0
Xin chào huuthang_bd, vanthinh3101

Một bài tập nữa tương tự với trường hợp bài #4, Oanh thơ cũng đã loay hoay suốt nhưng chưa giải quyết được vấn đề
nhờ anh huuthang_bd, và bạn vanthinh3101 cùng mọi người trên GPE sửa lại code để lấy dữ liệu theo tập tin gửi kèm với ạ.
 

File đính kèm

Upvote 0
Chào các AC,
Mình có trường hợp cần gộp các file excel thành 1 file. Trong file data , có cột ID, định dạng là text ( "001", "002",....). Khi dùng code (code của AC share) thì khi gộp các file, kết quả la cột ID trở thành định dạng number ("1", "2",...) . Mình muốn Cột ID vẫn có định dạng text ( "001", "002",....).Các AC giúp mình khắc phục lỗi này với. Mình đính kèm 1 file tonghop, 2 file data.
Trân trọng & Cảm ơn
Ngọc Phương
 

File đính kèm

Upvote 0
Chào các AC,
Mình có trường hợp cần gộp các file excel thành 1 file. Trong file data , có cột ID, định dạng là text ( "001", "002",....). Khi dùng code (code của AC share) thì khi gộp các file, kết quả la cột ID trở thành định dạng number ("1", "2",...) . Mình muốn Cột ID vẫn có định dạng text ( "001", "002",....).Các AC giúp mình khắc phục lỗi này với. Mình đính kèm 1 file tonghop, 2 file data.
Trân trọng & Cảm ơn
Ngọc Phương
Them lệnh format Text
Mã:
...
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).NumberFormat = "@"
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
....
 
Upvote 0
Xin chào huuthang_bd, vanthinh3101

Một bài tập nữa tương tự với trường hợp bài #4, Oanh thơ cũng đã loay hoay suốt nhưng chưa giải quyết được vấn đề
nhờ anh huuthang_bd, và bạn vanthinh3101 cùng mọi người trên GPE sửa lại code để lấy dữ liệu theo tập tin gửi kèm với ạ.
Thử code
Mã:
Sub Gop_Data()
  Dim cn As Object, strSQL As String
  Dim dArr As Variant, lR As Long, i As Long, j As Integer
  Application.ScreenUpdating = False
  With Sheets("T8")
    lR = .Range("G" & Rows.Count).End(xlUp).Row
    If lR > 2 Then .Range("C3:AM" & lR).ClearContents
  End With
  With Sheets("Nguon")
    lR = .Range("C" & Rows.Count).End(xlUp).Row
    If lR < 3 Then MsgBox ("Khong co du lieu nguon, thoat Sub"): Exit Sub
    dArr = .Range("C3:AAA" & lR).Value
  End With
  Set cn = CreateObject("ADODB.Connection")
  On Error Resume Next
  For i = 1 To UBound(dArr)
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\T8\" & dArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
    For j = 2 To UBound(dArr, 2)
      If dArr(i, j) = "" Then Exit For
      strSQL = "select * from [" & dArr(i, j) & "$D15:AN] where f5 is not null"
      With Sheets("T8")
        lR = .Range("G" & Rows.Count).End(xlUp).Row
        .Range("C" & lR + 1).CopyFromRecordset cn.Execute(strSQL)
      End With
    Next j
    cn.Close
  Next i
  Set cn = Nothing
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Chào các AC,
Mình cần gộp các file excel (ví dụ: File "Thang1" có dữ liệu trong sheet "Thang1", File "Thang2" có dữ liệu trong sheet "Thang2",....) thành 1 file.
Trong code (code của AC share) thì chỉ gộp được các file excel với "sheet1".
.....
If TypeName(vFile) = "Variant()" Then
SheetName = "Sheet1": RangeAddress = "A2:Z10000"
......

Các AC code giúp mình gộp các file excel trong trường hợp của mình với.
Trân trọng & Cảm ơn
Ngọc Phương
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom