Xin code VBA tổng hợp điểm của sinh viên từ nhiều sheet

2dnq · 6/9/23

Xin nhờ các anh chị trên diễn dàn giúp em,

Em có 1 file excel gồm 1 sheet tổng hợp và nhiều sheet chứa điểm của sinh viên của các môn học khác nhau. Em muốn tổng hợp lại vào sheet tổng hợp điểm các môn như trong file. Em có dùng hàm INDEX và MATCH để dò tìm nhưng kết quả khá lâu vì mỗi sinh viên chưa có mã và phải tìm kiếm theo họ tên +ngày sinh và số học sinh ở các sheet điểm lại không đồng bộ. Vì vậy xin các anh chị em trên diễn đàn giúp đỡ code VBA ạ. Em cảm ơn

Maika8008 · 6/9/23

Quản lý sinh viên mà không có mã số SV, hay vậy ta?

HUONGHCKT · 6/9/23

2dnq đã viết:
Xin nhờ các anh chị trên diễn dàn giúp em,

Em có 1 file excel gồm 1 sheet tổng hợp và nhiều sheet chứa điểm của sinh viên của các môn học khác nhau. Em muốn tổng hợp lại vào sheet tổng hợp điểm các môn như trong file. Em có dùng hàm INDEX và MATCH để dò tìm nhưng kết quả khá lâu vì mỗi sinh viên chưa có mã và phải tìm kiếm theo họ tên +ngày sinh và số học sinh ở các sheet điểm lại không đồng bộ. Vì vậy xin các anh chị em trên diễn đàn giúp đỡ code VBA ạ. Em cảm ơn

Trong khi chờ các giải pháp khác có thể dùng tạm code này.

Mã:

Option Explicit

Sub TongHop()
Dim i&, j&, t&, k&, Lr&, Col&
Dim Arr(), KQ()
Dim Dic As Object, Key As String
Dim Ws As Worksheet, Sh As Worksheet
Set Sh = Sheets("TongHop")
Set Dic = CreateObject("Scripting.Dictionary")
ReDim KQ(1 To 1000, 1 To 50)
k = 1: t = 2
For Each Ws In Worksheets
    If Ws.Name <> "TongHop" Then
        Lr = Ws.Cells(10000, "C").End(3).Row
        k = k + 1: Col = k * 2 + 1
        If k = 2 Then KQ(1, 1) = Ws.[A6]: KQ(1, 2) = Ws.[B6]: KQ(1, 3) = Ws.[C6]: KQ(1, 4) = Ws.[D6]:
        KQ(1, Col) = Ws.Name
        KQ(2, Col) = Ws.[E7]: KQ(2, Col + 1) = Ws.[F7]
        If Lr <= 7 Then Exit Sub
            Arr = Ws.Range("A8:F" & Lr).Value
        For i = 1 To UBound(Arr)
            Key = Arr(i, 3) & "#" & Arr(i, 4)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                KQ(t, 1) = t - 2
                KQ(t, 2) = Arr(i, 2)
                KQ(t, 3) = Arr(i, 3)
                KQ(t, 4) = Arr(i, 4)
                KQ(t, Col) = Arr(i, 5)
                KQ(t, Col + 1) = Arr(i, 6)
            Else
                j = Dic.Item(Key)
                KQ(j, Col) = Arr(i, 5)
                KQ(j, Col + 1) = Arr(i, 6)
            End If
        Next i
    End If
Next Ws
If t Then
    Sh.Range("A6").Resize(10000, Col + 1).ClearContents
    Sh.Range("A6").Resize(10000, Col + 1).Borders.LineStyle = xlNone
    Sh.Range("A6").Resize(t, Col + 1) = KQ
    Sh.Range("A6").Resize(t, Col + 1).Borders.LineStyle = 1
End If
Set Dic = Nothing
MsgBox "Đa xong"
End Sub

Xem file đính kèm.
Nhấn vào mặt cười để xem điều gì đã diễn ra.
Nhớ test kỹ.

Thóc Sama · 6/9/23

Góp vui

PHP:

Option Compare Text
Sub GPE()
    Dim sTh$, Dic As Object, Key, i&, j&, k&, ns
    Dim Arr(), Res(), Lr&, Ws As Worksheet, a&
    Set Dic = CreateObject("scripting.Dictionary")
    sTh = "t" & ChrW(7893) & "ng h" & ChrW(7907) & "p"
    For Each Ws In Sheets
        If Ws.Name <> sTh Then
            With Ws
                Lr = .Range("B" & Rows.Count).End(xlUp).Row
                Arr = .Range("B8:F" & Lr).Value
                For i = 1 To UBound(Arr)
                    ns = CLng(DateSerial(Split(Arr(i, 3), ".")(2), Split(Arr(i, 3), ".")(1), Split(Arr(i, 3), ".")(0)))
                    Key = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2)) & "|" & ns & "|" & Trim(Ws.Name)
                    If Not Dic.exists(Key) Then Dic.Add (Key), Arr(i, 4) & "|" & Arr(i, 5)
                Next i
            End With
        End If
    Next Ws
    With ThisWorkbook.Sheets(sTh)
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("A6:T" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 16)
        For i = 3 To UBound(Arr)
            ns = CLng(DateSerial(Split(Arr(i, 4), ".")(2), Split(Arr(i, 4), ".")(1), Split(Arr(i, 4), ".")(0)))
            k = k + 1: a = 0
            For j = 5 To UBound(Arr, 2) Step 2
                a = a + 1
                Key = Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 3)) & "|" & ns & "|" & Trim(Arr(1, j))
                If Dic.exists(Key) Then
                    Res(k, a) = Split(Dic.Item(Key), "|")(0)
                    Res(k, a + 1) = Split(Dic.Item(Key), "|")(1)
                End If
                a = a + 1
            Next j
        Next i
        .Range("E8:T" & Lr).ClearContents
        .Range("E8").Resize(k, 16).Value = Res
    End With
    MsgBox "Done"
    Set Dic = Nothing
End Sub

Maika8008 · 6/9/23

Bài này chỉ dùng vòng lặp thôi cũng được. Thử không dùng dic rồi so sánh với dùng dic xem chậm hơn cỡ bao nhiêu % nhỉ?

2dnq · 6/9/23

Maika8008 đã viết:
Quản lý sinh viên mà không có mã số SV, hay vậy ta?

dạ. Mã sv thêm sau ạ

HUONGHCKT đã viết:

Trong khi chờ các giải pháp khác có thể dùng tạm code này.

Mã:

Option Explicit

Sub TongHop()
Dim i&, j&, t&, k&, Lr&, Col&
Dim Arr(), KQ()
Dim Dic As Object, Key As String
Dim Ws As Worksheet, Sh As Worksheet
Set Sh = Sheets("TongHop")
Set Dic = CreateObject("Scripting.Dictionary")
ReDim KQ(1 To 1000, 1 To 50)
k = 1: t = 2
For Each Ws In Worksheets
    If Ws.Name <> "TongHop" Then
        Lr = Ws.Cells(10000, "C").End(3).Row
        k = k + 1: Col = k * 2 + 1
        If k = 2 Then KQ(1, 1) = Ws.[A6]: KQ(1, 2) = Ws.[B6]: KQ(1, 3) = Ws.[C6]: KQ(1, 4) = Ws.[D6]:
        KQ(1, Col) = Ws.Name
        KQ(2, Col) = Ws.[E7]: KQ(2, Col + 1) = Ws.[F7]
        If Lr <= 7 Then Exit Sub
            Arr = Ws.Range("A8:F" & Lr).Value
        For i = 1 To UBound(Arr)
            Key = Arr(i, 3) & "#" & Arr(i, 4)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                KQ(t, 1) = t - 2
                KQ(t, 2) = Arr(i, 2)
                KQ(t, 3) = Arr(i, 3)
                KQ(t, 4) = Arr(i, 4)
                KQ(t, Col) = Arr(i, 5)
                KQ(t, Col + 1) = Arr(i, 6)
            Else
                j = Dic.Item(Key)
                KQ(j, Col) = Arr(i, 5)
                KQ(j, Col + 1) = Arr(i, 6)
            End If
        Next i
    End If
Next Ws
If t Then
    Sh.Range("A6").Resize(10000, Col + 1).ClearContents
    Sh.Range("A6").Resize(10000, Col + 1).Borders.LineStyle = xlNone
    Sh.Range("A6").Resize(t, Col + 1) = KQ
    Sh.Range("A6").Resize(t, Col + 1).Borders.LineStyle = 1
End If
Set Dic = Nothing
MsgBox "Đa xong"
End Sub

Xem file đính kèm.
Nhấn vào mặt cười để xem điều gì đã diễn ra.
Nhớ test kỹ.

Em cám ơn ạ

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

Thóc Sama đã viết:

Góp vui

PHP:

Option Compare Text
Sub GPE()
    Dim sTh$, Dic As Object, Key, i&, j&, k&, ns
    Dim Arr(), Res(), Lr&, Ws As Worksheet, a&
    Set Dic = CreateObject("scripting.Dictionary")
    sTh = "t" & ChrW(7893) & "ng h" & ChrW(7907) & "p"
    For Each Ws In Sheets
        If Ws.Name <> sTh Then
            With Ws
                Lr = .Range("B" & Rows.Count).End(xlUp).Row
                Arr = .Range("B8:F" & Lr).Value
                For i = 1 To UBound(Arr)
                    ns = CLng(DateSerial(Split(Arr(i, 3), ".")(2), Split(Arr(i, 3), ".")(1), Split(Arr(i, 3), ".")(0)))
                    Key = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2)) & "|" & ns & "|" & Trim(Ws.Name)
                    If Not Dic.exists(Key) Then Dic.Add (Key), Arr(i, 4) & "|" & Arr(i, 5)
                Next i
            End With
        End If
    Next Ws
    With ThisWorkbook.Sheets(sTh)
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("A6:T" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 16)
        For i = 3 To UBound(Arr)
            ns = CLng(DateSerial(Split(Arr(i, 4), ".")(2), Split(Arr(i, 4), ".")(1), Split(Arr(i, 4), ".")(0)))
            k = k + 1: a = 0
            For j = 5 To UBound(Arr, 2) Step 2
                a = a + 1
                Key = Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 3)) & "|" & ns & "|" & Trim(Arr(1, j))
                If Dic.exists(Key) Then
                    Res(k, a) = Split(Dic.Item(Key), "|")(0)
                    Res(k, a + 1) = Split(Dic.Item(Key), "|")(1)
                End If
                a = a + 1
            Next j
        Next i
        .Range("E8:T" & Lr).ClearContents
        .Range("E8").Resize(k, 16).Value = Res
    End With
    MsgBox "Done"
    Set Dic = Nothing
End Sub

Em cảm ơn ạ

VetMini · 6/9/23

Maika8008 đã viết:
Quản lý sinh viên mà không có mã số SV, hay vậy ta?

Đâu có cần hay.
Miễn xin được code chạy ra kết quả mong muốn thôi chứ. Hỏi tác giả code chứ tác giả file làm gì.

Maika8008 · 6/9/23

2dnq đã viết:
dạ. Mã sv thêm sau ạ

Thêm sau là thế nào. Nếu SV Nguyễn Văn A sinh ngày 12/6/2004 với SV Nguyễn Văn A sinh ngày 12/06/2004 thì bạn nghĩ code sẽ xem đó là 2 người hay 1 người?

tranvansau278 · 6/9/23

Cái này mình cũng xài hàm của bạn, nhưng nó nhẹ hơn nhiều. Thay vì tham chiếu tới tất cả các dòng của cột B, C, D thì mình chỉ lấy tới số 100 thôi.

Xin code VBA tổng hợp điểm của sinh viên từ nhiều sheet

2dnq

Thành viên mới

File đính kèm

Maika8008

Thành viên gạo cội

HUONGHCKT

Zalo 0986997214

File đính kèm

Thóc Sama

＿/＿/＿/＿/＿/＿/＿/

File đính kèm

Maika8008

Thành viên gạo cội

2dnq

Thành viên mới

VetMini

Ăn cùng góc phố

Maika8008

Thành viên gạo cội

tranvansau278

Thành viên mới

File đính kèm

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

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng