Xin hỏi cách tạo form nhập liệu tự động về các sheet có sẵn

[dodinhkhai]

Em chào các anh.
Em đang có nhu cầu thế này: Có danh sách học sinh các lớp với đầy đủ các thông tin cá nhân rồi. Trong quá trình học có thể thông tin đó được bổ sung. Có nhiều người cùng phải bổ sung thêm thông tin. Nếu 1 vài người thì mình có thể tìm tới mục của họ để điền thêm nhưng nếu mỗi lần thay đổi có khoảng 50 người thì tìm từng người một để thêm thông tin thì thật là vất vả.
Vậy nên e muốn hỏi các anh cách tạo 1 form nhập liệu như vậy.
Em đã tạo 1 file excel và trình bày rõ mục đích yêu cầu trong đó, mong các anh giúp đỡ!

 

[SA_DQ]

file mới thêm HTnhap, bạn kiểm tra lại nha

Thay file lúc 19h30

 

[SA_DQ]

bên cột NH hưởng e mặc định MB Sơn Tây thầy cố định luôn hay e tự đánh

Ở cột 'E' thuộc trang tính 'TTQT' vì nó đứng trước cột [TTien], nên macro làm mất sau mỗi lần nó chạy;
Có nhiều cách để sau khi chạy macro vẫn còn mệnh đề này; Sau đây mình hướng dẫn cách bạn sửa trong macro:
Trước tiên nhập cụm từ cần hiện trên dữ liệu BC của trang 'TTQP' vô 1 ô trống nào đó tại 'DMuc', như [P1];
Tiến hành gán cho nó cái tên 'ST' (hay gì, gì khác cũng được)
Sau đó vô CS VBE, mở macro này lên

Private Sub CmdTTQT_Click()
  Dim W As Long, J As Long, Rws As Long, Dm As Integer
  Dim Arr(), Dict As Object
  Dim STay As String     '**    '
  
  Set Dict = CreateObject("Scripting.Dictionary")
  Sheets("TTQT").Select
  STay = Sheets("DMuc").Range("ST").Value    '**    '
  With Sheets("CSDL")
    Rws = .[b2].CurrentRegion.Rows.Count
    Arr() = .[b2].Resize(Rws, 9).Value
    ReDim dArr(1 To Rws, 1 To 6)
     [A9:F79].ClearContents:                                    Rows("9:79").Hidden = False
    For J = 1 To UBound(Arr())
        If IsEmpty(Arr(J, 2)) Then Exit For
        If Arr(J, 1) >= TxtToDat(Me!tbfDat.Value) And Arr(J, 1) <= TxtToDat(Me!tblDat.Value) Then
             If Not Dict.exists(Arr(J, 2)) Then
                W = W + 1:                                          Dict.Add Arr(J, 2), W
                dArr(W, 1) = W:                                     dArr(W, 6) = Arr(J, 9)
                For Dm = 2 To 3
                    dArr(W, Dm) = Arr(J, Dm)
                Next Dm
                dArr(W, 4) = "'" & Arr(J, 4)
                dArr(W, 5) = STay   '  **     '
            Else
                dArr(Dict.Item(Arr(J, 2)), 6) = dArr(Dict.Item(Arr(J, 2)), 6) + Arr(J, 9)
            End If
        End If
    Next J
  End With
  If W Then
    [A9].Resize(W, 6).Value = dArr()
  End If
  J = Switch(W < 10, 20, W < 16, 30, W < 30, 45, W < 50, 68, W < 72, W + 2)
  Rows(J & ":78").Hidden = True
  Sheets("TTQT").Select
End Sub

& Thêm các mệnh đề mới vô macro (những dòng có '** ' đó
(húc thành công nhiều!

 

[SA_DQ]

Còn đây là cặp đôi macro cha & con ở trrang 'NienHan' khi gộp file CapPhatQT vô file "Chuyen KT"

Dim dArr()

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [Af1]) Is Nothing Then
    Dim Thg As Byte, W As Integer, Rws As Long, J As Integer
    
    Thg = Choose(Target.Value, 1, 4, 7, 10, 35)
    Rws = [B59999].End(xlUp).Row + 9
    Range("A6:BE" & Rws).Clear
    For J = Thg To Thg + 2
        [B9999].End(xlUp).Offset(1).Value = "Tháng " & Right("0" & CStr(J), 2)
        THQuanTrang J
    Next J
 End If
End Sub

Sub THQuanTrang(Thg As Integer)
 Dim Rws As Long, W As Integer, Col As Integer, J As Long
 Dim Arr(), Dict As Object
 Dim Tmp As String, TF As String
 
 Set Dict = CreateObject("Scripting.Dictionary")
 With Sheets("CSDL")
    Rws = .[B2].CurrentRegion.Rows.Count:                                       Arr() = .[B2].Resize(Rws, 9).Value
    ReDim dArr(1 To Rws, 1 To 55):                                                  ReDim sArr(1 To 1, 1 To 54)
    sArr(1, 1) = Sheets("DMuc").Range("GPE").Value                           ' Tiêng Viêt Tông Công    '
    For J = 1 To UBound(Arr())
        If Arr(J, 1) = "" Then Exit For
        If Month(Arr(J, 1)) = Thg Then
            Tmp = Arr(J, 2) & Arr(J, 5):                                                TF = Arr(J, 7)
            Col = Switch(TF = "AK_", 4, TF = "AM_", 6, TF = "Asn", 8, TF = "Atn", 10, TF = "AX_", 12, TF = "BL_", 14, TF = "BT_", 16, TF = "CH_", 18, TF = "CR_", 20, _
                    TF = "DL_", 22, TF = "Dn0", 24, TF = "Dn1", 26, TF = "GyT", 28, TF = "GyU", 30, TF = "KCR_", 32, TF = "KM_", 34, TF = "Mn_", 36, TF = "Mu_", 38, _
                        TF = "Qn_", 40, TF = "QP_", 42, TF = "QP1", 44, TF = "QP2", 46, TF = "Qtn", 48, TF = "RC_", 50, TF = "TL_", 52, TF = "VC_", 54)
            If Not Dict.exists(Tmp) Then
                W = W + 1:                                                                      Dict.Add Tmp, W
                dArr(W, 1) = W:                                                                dArr(W, 2) = Arr(J, 3)
                dArr(W, 3) = Arr(J, 5)
                dArr(W, Col) = Arr(J, 8):                                                   dArr(W, 1 + Col) = Arr(J, 9)
            Else
                 dArr(Dict.Item(Tmp), Col) = dArr(Dict.Item(Tmp), Col) + Arr(J, 8)
                dArr(Dict.Item(Tmp), 1 + Col) = dArr(Dict.Item(Tmp), 1 + Col) + Arr(J, 9)
            End If
            sArr(1, Col - 1) = sArr(1, Col - 1) + Arr(J, 8):                            sArr(1, Col) = sArr(1, Col) + Arr(J, 9)
        End If
    Next J
 End With
 If W = 0 Then Exit Sub
 Sheets("NienHan").[B9999].End(xlUp).Offset(1, -1).Resize(W, 55).Value = dArr()
 Sheets("NienHan").[B9999].End(xlUp).Offset(1).Resize(, 54).Value = sArr()
End Sub

 

[SA_DQ]

Đây là macro tạo báo cáo tháng trong file 'TangGia':

Private Sub CmdBCT_Click()
 Dim Arr(), Cls As Range:                                       Dim Dm As Long, J As Long, Rws As Long
 Dim fDat As Date, lDat As Date, SLg1 As Double, SLgbc As Double, TT1 As Double, TTbc As Double
 
 fDat = TxTToDat(Me!tbfD.Value):                          lDat = TxTToDat(Me!tblD.Value)
 
 With Sheets("Nhap")
    Rws = .[B4].CurrentRegion.Rows.Count
    Arr() = .[B4].Resize(Rws, 8).Value
 End With
 Sheets("Nam").Select
 [i1].Value = fDat:                                                 [j1].Value = lDat
 For Each Cls In Range([b7], [B32].End(xlUp))
    For J = 1 To UBound(Arr())
        If Arr(J, 1) = "" Then Exit For
        If Arr(J, 2) = Cls.Value Then
            If Arr(J, 1) < fDat Then
                SLg1 = SLg1 + Arr(J, 6):                        TT1 = TT1 + Arr(J, 8)
            ElseIf Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
                SLgbc = SLgbc + Arr(J, 6):                      TTbc = TTbc + Arr(J, 8)
            Else
            End If
        End If
    Next J
    Cls.Offset(, 3).Value = SLgbc:                          SLgbc = 0
    Cls.Offset(, 4).Value = TTbc:                           TTbc = 0
    Cls.Offset(, 7) = CStr(SLg1) & "; " & Str(TT1)
    SLg1 = 0:                                                       TT1 = 0
 Next Cls
End Sub

 

[SA_DQ]

Còn ca báo cáo tháng loại này là khó nên phải xài đến 2 dao mổ Dictionary:

Private Sub CmdCT_Click()
 Dim Arr(), Dict As Object, Dic_ As Object
 Dim W As Integer, Z As Integer, J As Long, Rws As Long, Dm As Integer, fDat As Date, lDat As Date
On Error GoTo LoiCT
 Set Dict = CreateObject("Scripting.Dictionary")
 Set Dic_ = CreateObject("Scripting.Dictionary")
 lDat = Me!tbNCT.Value:                                 fDat = DateSerial(Year(lDat), Month(lDat), 1)
 With Sheets("Nhap")
    Rws = .[B4].CurrentRegion.Rows.Count:       Arr() = .[B4].Resize(Rws, 8).Value
  End With
  ReDim cArr(1 To 2, 1 To 26 * 3) As String
  ReDim dArr(1 To 31, 1 To 26 * 3)
  For J = 1 To UBound(Arr())
    If IsEmpty(Arr(J, 2)) Then Exit For
    If Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
        If Not Dic_.exists(Arr(J, 2)) Then
            Z = Z + 1:                                          Dic_.Add Arr(J, 2), Z
            cArr(1, 3 * Z - 2) = Arr(J, 2):                 cArr(2, 3 * Z - 2) = "S Con"
            cArr(2, 3 * Z - 1) = "Sô Lg":                   cArr(2, 3 * Z) = "T Tiên":
        End If
        If Not Dict.exists(Arr(J, 1)) Then
            W = W + 1:                                      Dict.Add Arr(J, 1), W
            dArr(W, 1) = Arr(J, 1)
            For Dm = 1 To Z * 3 + 4 Step 3
                If cArr(1, Dm) <> "" Then
                    If cArr(1, Dm) = Arr(J, 2) Then
                        dArr(W, Dm + 1) = Arr(J, 5):    dArr(W, Dm + 2) = Arr(J, 6)
                        dArr(W, Dm + 3) = Arr(J, 8)
                    End If
                Else
                    Exit For
                End If
            Next Dm
        Else
            For Dm = 1 To Z * 3 + 4 Step 3
                If cArr(1, Dm) <> "" Then
                    If cArr(1, Dm) = Arr(J, 2) Then
                        dArr(Dict.Item(Arr(J, 1)), Dm + 1) = dArr(Dict.Item(Arr(J, 1)), Dm + 1) + Arr(J, 5)
                        dArr(Dict.Item(Arr(J, 1)), Dm + 2) = dArr(Dict.Item(Arr(J, 1)), Dm + 2) + Arr(J, 6)
                        dArr(Dict.Item(Arr(J, 1)), Dm + 3) = dArr(Dict.Item(Arr(J, 1)), Dm + 3) + Arr(J, 8)
                    End If
                Else
                    Exit For
                End If
            Next Dm
        End If
    End If
  Next J
  With Sheets("CTiet")
    .[A8].Resize(31, 3 * 25).ClearContents:         .[b6].Resize(2, 26 * 3).ClearContents
    If W Then
        .[b6].Resize(2, 3 * Z).Value = cArr():        .[A8].Resize(W, 3 * Z + 1).Value = dArr()
    End If
    .[S1].Value = Month(fDat):                          .Select
 End With
Err_:            Exit Sub
LoiCT:
    If Err = 9 Then
        Resume Next
    Else
        MsgBox Err
        Resume Err_
    End If
End Sub

 

[SA_DQ]

Để có thể xoay bảng báo cáo như theo hình (đính kèm) ta có thể nhờ macro này:

Private Sub CmdBC__Click()
 Dim Arr(), Dict As Object, Dic_ As Object
 Dim W As Integer, Z As Integer, J As Long, Rws As Long, Dm As Integer, fDat As Date, lDat As Date
' On Error GoTo Loi_CT
 Set Dict = CreateObject("Scripting.Dictionary")
 Set Dic_ = CreateObject("Scripting.Dictionary")
 lDat = TxTToDat(Me!tbNCT.Value)
 fDat = DateSerial(Year(lDat), Month(lDat), 1)
 With Sheets("Nhap")
    Rws = .[B4].CurrentRegion.Rows.Count:       Arr() = .[B4].Resize(Rws, 8).Value
  End With
  ReDim cArr(1 To 2, 1 To 26 * 3) As Date
  ReDim dArr(1 To 26 * 3, 1 To 33)
 For J = 1 To UBound(Arr())
    If IsEmpty(Arr(J, 2)) Then Exit For
    If Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
        If Not Dic_.exists(Arr(J, 1)) Then
            Z = Z + 1:                                          Dic_.Add Arr(J, 1), Z
            cArr(1, Z) = Arr(J, 1)
        End If
        If Not Dict.exists(Arr(J, 2)) Then
            If W = 0 Then W = 1 Else W = W + 3:     Dict.Add Arr(J, 2), W
            dArr(W, 1) = Arr(J, 2):                         dArr(W, 2) = "Sô Con"
            dArr(W + 1, 2) = "Sô Lg":                       dArr(W + 2, 2) = "T.Tiên"
            For Dm = 1 To Z
                If cArr(1, Dm) = Arr(J, 1) Then
                    dArr(W, Dm + 2) = Arr(J, 5):        dArr(W + 1, Dm + 2) = Arr(J, 6)
                    dArr(W + 2, Dm + 2) = Arr(J, 8)
                End If
            Next Dm
        Else
            For Dm = 1 To Z
                If cArr(1, Dm) = Arr(J, 1) Then
                    dArr(Dict.Item(Arr(J, 2)), Dm + 2) = dArr(Dict.Item(Arr(J, 2)), Dm + 2) + Arr(J, 5)
                    dArr(Dict.Item(Arr(J, 2)) + 1, Dm + 2) = dArr(Dict.Item(Arr(J, 2)) + 1, Dm + 2) + Arr(J, 6)
                    dArr(Dict.Item(Arr(J, 2)) + 2, Dm + 2) = dArr(Dict.Item(Arr(J, 2)) + 2, Dm + 2) + Arr(J, 8)
                End If
            Next Dm
        End If
    End If
 Next J
 With Sheets("BCT")
    .[c7].Resize(, 31).ClearContents:               .[A8].Resize(25 * 3, 35).ClearContents
    If W Then
        .[c7].Resize(, Z).Value = cArr():           .[A8].Resize(W + 3, Z + 2).Value = dArr()
        .[s1].Value = Month(Me!tbNCT.Value)
    End If
    .Select
 End With
Loi_CT:
End Sub

Mã ĐV	Ngày	01/06	03/06	05/06	07/06	08/06	09/06	11/06	13/06	15/06	17/06
D16	Số Con	28​
Số Lg	29.5​
T.Tiên	973500​
D6_	Số Con		1.5​		2​
Số Lg		148.8​		198​
T.Tiên		5959440​		7326000​
H4_	Số Con			1​
Số Lg			101​
T.Tiên			3838000​
D5_	Số Con				20​
Số Lg				24​
T.Tiên				912000​
H7_	Số Con					13​
Số Lg					15.5​
T.Tiên					511500​
D8_	Số Con						28​
Số Lg						29.5​
T.Tiên						973500​
D9_	Số Con							1.5​
Số Lg							148.8​
T.Tiên							5959440​
D10	Số Con								1​
Số Lg								101​
T.Tiên								3838000​