Nhờ hỗ trợ VBA copy dữ liệu từ nhiều file vào một file

[Thóc Sama]

Xin chào các Anh/Chị!
Hiện em đang tạo file LIST TONG HOP để tổng hợp kết quả trong các file kết quả test nhân viên (bài kết quả test NV có hơn 1000 bài và em lấy vị dụ ở đây là 2 bài phía dưới).
(2051-SX-S122-*,2051-SX-S123*).
Anh/Chị nào rành về phần VBA cho em xin đoạn code để khi chạy đoạn Code đó thì những thông tin cụ thể trong các file kết quả test NV sẽ được Copy vào LIST TONG HOP ví dụ như: MSNV, HỌ TÊN, BỘ PHẬN...
Xin đa tạ các Anh/Chị ạ!

 

[HUONGLIEN6577]

Sẽ có người giúp bạn, nhưng có một số ý kiến nhỏ góp ý:
1/ Tên Sheet :"Xin ngài dùng tiếng Việt"
2/ Cái file có sheet tiếng Trung gì đó, nên đặt chung vào file LIST TONG HOP, thì sẽ dễ làm hơn.
3/ Bạn hãy tìm bài : dùng Sheet làm form nhập liệu để tham khảo nhé.
& chúc vui

 

[Thóc Sama]

Sẽ có người giúp bạn, nhưng có một số ý kiến nhỏ góp ý:
1/ Tên Sheet :"Xin ngài dùng tiếng Việt"
2/ Cái file có sheet tiếng Trung gì đó, nên đặt chung vào file LIST TONG HOP, thì sẽ dễ làm hơn.
3/ Bạn hãy tìm bài : dùng Sheet làm form nhập liệu để tham khảo nhé.
& chúc vui

Cám ơn thông tin từ bạn, mình sẽ rút kinh nghiệm!

 

[Nhattanktnn]

Cám ơn thông tin từ bạn, mình sẽ rút kinh nghiệm!

Một điều nữa là tiêu đề của bạn đang phạm quy, để không mất thời gian của bạn quay lại đọc nội quy thì mình chỉ ra 2 điểm như sau:
1/ Tiêu đề không được viết hoa toàn bộ
2/ Tiêu đề phải liên quan đến nội dung cụ thể của bài. Đại loại "Tổng hợp dữ liệu từ nhiều file về một file"

 

[Nhattanktnn]

Xin chào các Anh/Chị!
Hiện em đang tạo file LIST TONG HOP để tổng hợp kết quả trong các file kết quả test nhân viên (bài kết quả test NV có hơn 1000 bài và em lấy vị dụ ở đây là 2 bài phía dưới).
(2051-SX-S122-*,2051-SX-S123*).
Anh/Chị nào rành về phần VBA cho em xin đoạn code để khi chạy đoạn Code đó thì những thông tin cụ thể trong các file kết quả test NV sẽ được Copy vào LIST TONG HOP ví dụ như: MSNV, HỌ TÊN, BỘ PHẬN...
Xin đa tạ các Anh/Chị ạ!

Nếu có thể thì tên sheet các file con bạn thay đổi tên sheet về giống nhau (tốt nhất đừng dùng tiếng Trung). Trong code dưới chỉ lấy file có 1 sheet, nhiều sheet có thể có lỗi (vì tên sheet không giống nhau nên mình không dùng tên sheet nữa)
Đưa các file vào chung 1 folder, copy code vào module file tổng rồi chạy code:

Option Explicit
Sub NTKTNN()
Dim Fso As Object, oFile As Object, dArr(1 To 10000, 1 To 8)
Dim sPath As String, I As Long, vArray
'*************************************************************
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = ThisWorkbook.Path
'*************************************************************
With CreateObject("ADODB.Recordset")
    For Each oFile In Fso.GetFolder(sPath).Files
        If Left(oFile.Name, 1) <> "~" Then
        If Fso.GetExtensionName(oFile) Like "xls*" Then
        If oFile.Name <> ThisWorkbook.Name Then
            .Open ("Select F4,F19,F23 from [$D2:Z10]"), _
            "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & sPath & "\" & oFile.Name
            vArray = TransArr(.GetRows())
            I = I + 1
            dArr(I, 1) = I
            dArr(I, 2) = vArray(0, 0)
            dArr(I, 3) = vArray(2, 0)
            dArr(I, 4) = vArray(4, 0)
            dArr(I, 5) = vArray(6, 0)
            dArr(I, 6) = vArray(4, 1)
            dArr(I, 7) = vArray(6, 1)
            dArr(I, 8) = vArray(4, 2)
            .Close
        End If: End If: End If
    Next
End With
'*************************************************************
With Sheets("Sheet1")
    .Rows("3:10000").ClearContents
    .Range("B3:I" & 2 + I) = dArr
End With
End Sub
Private Function TransArr(sArr As Variant) As Variant
    Dim cllX As Long, cllY As Long, tmpX As Long, tmpY As Long, tmpArr As Variant
    tmpX = UBound(sArr, 2):    tmpY = UBound(sArr, 1)
    ReDim tmpArr(tmpX, tmpY)
    For cllX = 0 To tmpX
        For cllY = 0 To tmpY
            tmpArr(cllX, cllY) = sArr(cllY, cllX)
        Next cllY
    Next cllX
    TransArr = tmpArr
End Function

 

[Thóc Sama]

Tuyệt vời quá!
Cám ơn bạn rất nhiều ạ!

Bài đã được tự động gộp: 4/6/21

Nếu có thể thì tên sheet các file con bạn thay đổi tên sheet về giống nhau (tốt nhất đừng dùng tiếng Trung). Trong code dưới chỉ lấy file có 1 sheet, nhiều sheet có thể có lỗi (vì tên sheet không giống nhau nên mình không dùng tên sheet nữa)
Đưa các file vào chung 1 folder, copy code vào module file tổng rồi chạy code:

Option Explicit
Sub NTKTNN()
Dim Fso As Object, oFile As Object, dArr(1 To 10000, 1 To 8)
Dim sPath As String, I As Long, vArray
'*************************************************************
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = ThisWorkbook.Path
'*************************************************************
With CreateObject("ADODB.Recordset")
    For Each oFile In Fso.GetFolder(sPath).Files
        If Left(oFile.Name, 1) <> "~" Then
        If Fso.GetExtensionName(oFile) Like "xls*" Then
        If oFile.Name <> ThisWorkbook.Name Then
            .Open ("Select F4,F19,F23 from [$D2:Z10]"), _
            "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & sPath & "\" & oFile.Name
            vArray = TransArr(.GetRows())
            I = I + 1
            dArr(I, 1) = I
            dArr(I, 2) = vArray(0, 0)
            dArr(I, 3) = vArray(2, 0)
            dArr(I, 4) = vArray(4, 0)
            dArr(I, 5) = vArray(6, 0)
            dArr(I, 6) = vArray(4, 1)
            dArr(I, 7) = vArray(6, 1)
            dArr(I, 8) = vArray(4, 2)
            .Close
        End If: End If: End If
    Next
End With
'*************************************************************
With Sheets("Sheet1")
    .Rows("3:10000").ClearContents
    .Range("B3:I" & 2 + I) = dArr
End With
End Sub
Private Function TransArr(sArr As Variant) As Variant
    Dim cllX As Long, cllY As Long, tmpX As Long, tmpY As Long, tmpArr As Variant
    tmpX = UBound(sArr, 2):    tmpY = UBound(sArr, 1)
    ReDim tmpArr(tmpX, tmpY)
    For cllX = 0 To tmpX
        For cllY = 0 To tmpY
            tmpArr(cllX, cllY) = sArr(cllY, cllX)
        Next cllY
    Next cllX
    TransArr = tmpArr
End Function

Tuyệt vời quá!
Cám ơn bạn rất nhiều ạ!