Kết nối dữ liệu nhiều file vào file tổng hợp (1 người xem)

[kulyvn]

Mình sử dụng VBA để kết nối các file vào file TongHop.xls bằng cách tạo 1 vùng 10 dòng trong sheet GPE ở file TongHop.xls để nhập tên các file cần lấy dữ liệu về file TongHop.xls .
Dữ liệu đã kết nối xong nhưng mình có tạo thêm cột "Nhân viên" ở cột DK trong file TongHop.xls để hiển thị tên file tương ứng với dữ liệu đã tổng hợp từ file đó. (chỉ cần hiển thị tên file (tên nhân viên) ở cột DK nên k cần đuôi .xls nhé)
Anh chị xem file đính kèm giúp mình nhé.
Thank!

 

[quanluu]

Mình sử dụng VBA để kết nối các file vào file TongHop.xls bằng cách tạo 1 vùng 10 dòng trong sheet GPE ở file TongHop.xls để nhập tên các file cần lấy dữ liệu về file TongHop.xls .
Dữ liệu đã kết nối xong nhưng mình có tạo thêm cột "Nhân viên" ở cột DK trong file TongHop.xls để hiển thị tên file tương ứng với dữ liệu đã tổng hợp từ file đó. (chỉ cần hiển thị tên file (tên nhân viên) ở cột DK nên k cần đuôi .xls nhé)
Anh chị xem file đính kèm giúp mình nhé.
Thank!

Bk hay DK vậy? nếu như file tổng hợp là BK. Mà cái của bạn có code rùi đây? nếu là bạn nhờ, thì bạn nhờ lại ng đó.

 

[kulyvn]

sry mình nhầm, cột BK nha bạn , mình hỏi rồi không thấy hồi âm nên phải qua đây nhờ ae giúp thôi.
Có thể tag anh ấy vào được không nhỉ
http://www.giaiphapexcel.com/forum/member.php?163936-Ba-Tê

Bk hay DK vậy? nếu như file tổng hợp là BK. Mà cái của bạn có code rùi đây? nếu là bạn nhờ, thì bạn nhờ lại ng đó.

 

[quanluu]

sry mình nhầm, cột BK nha bạn , mình hỏi rồi không thấy hồi âm nên phải qua đây nhờ ae giúp thôi.
Có thể tag anh ấy vào được không nhỉ
http://www.giaiphapexcel.com/forum/member.php?163936-Ba-Tê

Để khi nào rảnh mình sẽ giúp bạn code khác vậy.

 

[kulyvn]

ok bạn , mình cám ơn trước nha

Để khi nào rảnh mình sẽ giúp bạn code khác vậy.

 

[quanluu]

ok bạn , mình cám ơn trước nha

Bạn check code nhé.
Mình để giói hạn dữ lieu các file con là <=1000 dòng, + các file con phải để chung folder với file tổng hợp.

Sub test()
Dim i As Integer, FSO As Object, stringfile As String, ItemFile As Object, wb As Workbook
Application.ScreenUpdating = False
Range("A10:BK" & Range("A65000").End(3).Row + 1).Clear
Set wb = ThisWorkbook
For i = 2 To 11
    stringfile = "|" & Sheets("GPE").Cells(i, 1) & "|" & stringfile
Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each ItemFile In FSO.GetFolder(ThisWorkbook.Path).Files
        If ItemFile.Name <> "TongHop.xls" And InStr(stringfile, "|" & ItemFile.Name & "|") Then
            Set cn = CreateObject("ADODB.Connection")
            cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ItemFile.Path & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
            Set rs = cn.Execute("SELECT A.*, '" & Split(ItemFile.Name, ".")(0) & "' as nv FROM [A10:BJ1000] as A where f1 is not null")
            wb.Sheets("THA").Range("A" & wb.Sheets("THA").Range("A65000").End(3).Row + 1).CopyFromRecordset rs
            rs.Close: cn.Close
        End If
    Next
    Range("A10:BK" & Range("A65000").End(3).Row).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub

 

[HieuCD]

thử thêm vài dòng bạn chạy thử

Option Explicit


Public Sub GPE_Tonghop()
Application.ScreenUpdating = False
Dim tArr(), sArr(), dArr(1 To 1000, 1 To 100), I As Long, J As Long, K As Long, N As Long, Pat As String
tArr = Sheets("GPE").Range("A2:A11").Value
Pat = ActiveWorkbook.Path & "\"
For N = 1 To 10
    If tArr(N, 1) <> "" Then
    On Error Resume Next
    Workbooks.Open Filename:=Pat & tArr(N, 1)
    If Err.Number <> 0 Then GoTo tiep
    With Sheets("THA")
        sArr = .Range("A10", .Range("A65536").End(xlUp)).Resize(, 100).Value
    End With
    For I = 1 To UBound(sArr)
        If sArr(I, 1) <> "" Then
            K = K + 1: dArr(K, 1) = K
            For J = 2 To 100
                dArr(K, J) = sArr(I, J)
            Next J
        dArr(K, 63) = Left(tArr(N, 1), Len(tArr(N, 1)) - 4)
        End If
        
    Next I
    ActiveWorkbook.Close False
    End If
tiep:
Err.Clear
Next N
Workbooks("Tonghop.xls").Activate
With Sheets("THA")
    .Range("A10").Resize(1000, 100).ClearContents
    .Range("A10").Resize(K, 100) = dArr
    .Range("B10").Resize(K, 99).Sort Key1:=.[H10], Key2:=.[G10]
End With
End Sub

 

[kulyvn]

cám ơn bạn nhiều nhé

thử thêm vài dòng bạn chạy thử

Option Explicit


Public Sub GPE_Tonghop()
Application.ScreenUpdating = False
Dim tArr(), sArr(), dArr(1 To 1000, 1 To 100), I As Long, J As Long, K As Long, N As Long, Pat As String
tArr = Sheets("GPE").Range("A2:A11").Value
Pat = ActiveWorkbook.Path & "\"
For N = 1 To 10
    If tArr(N, 1) <> "" Then
    On Error Resume Next
    Workbooks.Open Filename:=Pat & tArr(N, 1)
    If Err.Number <> 0 Then GoTo tiep
    With Sheets("THA")
        sArr = .Range("A10", .Range("A65536").End(xlUp)).Resize(, 100).Value
    End With
    For I = 1 To UBound(sArr)
        If sArr(I, 1) <> "" Then
            K = K + 1: dArr(K, 1) = K
            For J = 2 To 100
                dArr(K, J) = sArr(I, J)
            Next J
        dArr(K, 63) = Left(tArr(N, 1), Len(tArr(N, 1)) - 4)
        End If
        
    Next I
    ActiveWorkbook.Close False
    End If
tiep:
Err.Clear
Next N
Workbooks("Tonghop.xls").Activate
With Sheets("THA")
    .Range("A10").Resize(1000, 100).ClearContents
    .Range("A10").Resize(K, 100) = dArr
    .Range("B10").Resize(K, 99).Sort Key1:=.[H10], Key2:=.[G10]
End With
End Sub

 

[kulyvn]

cám ơn bạn nhiều nhé

Bạn check code nhé.
Mình để giói hạn dữ lieu các file con là <=1000 dòng, + các file con phải để chung folder với file tổng hợp.

Sub test()
Dim i As Integer, FSO As Object, stringfile As String, ItemFile As Object, wb As Workbook
Application.ScreenUpdating = False
Range("A10:BK" & Range("A65000").End(3).Row + 1).Clear
Set wb = ThisWorkbook
For i = 2 To 11
    stringfile = "|" & Sheets("GPE").Cells(i, 1) & "|" & stringfile
Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each ItemFile In FSO.GetFolder(ThisWorkbook.Path).Files
        If ItemFile.Name <> "TongHop.xls" And InStr(stringfile, "|" & ItemFile.Name & "|") Then
            Set cn = CreateObject("ADODB.Connection")
            cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ItemFile.Path & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
            Set rs = cn.Execute("SELECT A.*, '" & Split(ItemFile.Name, ".")(0) & "' as nv FROM [A10:BJ1000] as A where f1 is not null")
            wb.Sheets("THA").Range("A" & wb.Sheets("THA").Range("A65000").End(3).Row + 1).CopyFromRecordset rs
            rs.Close: cn.Close
        End If
    Next
    Range("A10:BK" & Range("A65000").End(3).Row).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub