Xin giúp đỡ về xếp ngày thi theo thời gian

Liên hệ QC

daitathan

Thành viên mới
Tham gia
17/3/07
Bài viết
28
Được thích
9
Chào anh/chị,
Em có cái lịch thi của từng môn học và từng nhóm học của môn đó. Em muốn xếp lịch thi theo thời gian. Nếu ngày thi môn nào và nhóm nào trước xếp trước, sau thì xếp sau (theo thứ tự ngày thi). Phân ra thi lần 1 và thi lần 2.
Anh chị nào có thể giúp em được không.
Em cảm ơn nhiều.
 

File đính kèm

  • lich thi.xlsx
    11.4 KB · Đọc: 12
Chào anh/chị,
Em có cái lịch thi của từng môn học và từng nhóm học của môn đó. Em muốn xếp lịch thi theo thời gian. Nếu ngày thi môn nào và nhóm nào trước xếp trước, sau thì xếp sau (theo thứ tự ngày thi). Phân ra thi lần 1 và thi lần 2.
Anh chị nào có thể giúp em được không.
Em cảm ơn nhiều.
Kết quả sau khi xếp sẽ như thế nào
 
Hiểu thế nào mần thế ý!
Có gì rỗi sẽ mần lại, mấy hồi!
 

File đính kèm

  • Date.rar
    16.4 KB · Đọc: 8
  • Mai01.jpg
    Mai01.jpg
    126.9 KB · Đọc: 4
Hiểu thế nào mần thế ý!
Có gì rỗi sẽ mần lại, mấy hồi!
Chào anh chị,
Ý mình khi mình có dữ liệu, muốn sắp xếp dữ liệu của từng môn học của từng lớp theo thời gian. File đính kèm mình làm thủ công. Sheet Du lieu là gốc, còn Lan 1 và Lan 2 mình copy và xếp thủ công theo ngày tháng tăng dần.
Anh chị giúp mình xếp dữ liệu trong excell. Nếu xếp thủ công thì sợ bị nhầm và thiếu.
Cảm ơn anh/chị nhiều.
 

File đính kèm

  • lich thi.xls
    50 KB · Đọc: 13
Chào anh chị,
Ý mình khi mình có dữ liệu, muốn sắp xếp dữ liệu của từng môn học của từng lớp theo thời gian. File đính kèm mình làm thủ công. Sheet Du lieu là gốc, còn Lan 1 và Lan 2 mình copy và xếp thủ công theo ngày tháng tăng dần.
Anh chị giúp mình xếp dữ liệu trong excell. Nếu xếp thủ công thì sợ bị nhầm và thiếu.
Cảm ơn anh/chị nhiều.
Bạn xem code.Đây là tách theo thi lần 1 nhé.
Mã:
Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
        Dim VB As Object
        Set VB = CreateObject("VBScript.regexp")
             VB.Global = True
             VB.Pattern = "\" & dk
            doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi()
    Dim arr, arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
    Set slist = CreateObject("System.Collections.ArrayList")
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
        ReDim arr1(1 To UBound(arr, 1), 1 To 9)
        For i = 1 To UBound(arr, 1)
            If Len(arr(i, 3)) = 0 Then
               If Len(arr(i + 1, 3)) = 0 Then
                  a = a + 1
                  mon = arr(i, 1)
                  arr1(a, 1) = mon
                  arr1(a, 2) = arr(i + 1, 1)
                  i = i + 1
                Else
                   a = a + 1
                   arr1(a, 1) = mon
                   arr1(a, 2) = arr(i, 1)
                End If
            Else
               If UCase(arr(i, 1)) = "THI L" & ChrW(7846) & "N 1" Then
                  arr1(a, 3) = "THI L" & ChrW(7846) & "N 1"
                  For j = 5 To 8
                      arr1(a, j) = arr(i, j - 2)
                  Next j
                  so = CDate(doingay(arr(i, 4), "h", ":"))
                  arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
                  slist.Add arr1(a, 9) & arr1(a,7)
               End If
           End If
       Next i
   End With
   Set olit = slist.Clone
   slist.Sort
   k = slist.Count
   ReDim arr2(1 To a, 1 To 8)
   For i = 0 To k - 1
       a = olit.InDexOf(slist(i), 0) + 1
       For j = 1 To 8
           arr2(i + 1, j) = arr1(a, j)
      Next j
   Next i
   With Sheets("lan 1")
       .Range("A3").Resize(k, 8).Value = arr2
   End With
End Sub
 
Lần chỉnh sửa cuối:
Bạn xem code.Đây là tách theo thi lần 1 nhé.
Mã:
Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
        Dim VB As Object
        Set VB = CreateObject("VBScript.regexp")
             VB.Global = True
             VB.Pattern = "\" & dk
            doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi()
    Dim arr, arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
    Set slist = CreateObject("System.Collections.ArrayList")
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
        ReDim arr1(1 To UBound(arr, 1), 1 To 9)
        For i = 1 To UBound(arr, 1)
            If Len(arr(i, 3)) = 0 Then
               If Len(arr(i + 1, 3)) = 0 Then
                  a = a + 1
                  mon = arr(i, 1)
                  arr1(a, 1) = mon
                  arr1(a, 2) = arr(i + 1, 1)
                  i = i + 1
                Else
                   a = a + 1
                   arr1(a, 1) = mon
                   arr1(a, 2) = arr(i, 1)
                End If
            Else
               If UCase(arr(i, 1)) = "THI L" & ChrW(7846) & "N 1" Then
                  arr1(a, 3) = "THI L" & ChrW(7846) & "N 1"
                  For j = 5 To 8
                      arr1(a, j) = arr(i, j - 2)
                  Next j
                  so = CDate(doingay(arr(i, 4), "h", ":"))
                  arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
                  slist.Add arr1(a, 9)
               End If
           End If
       Next i
   End With
   Set olit = slist.Clone
   slist.Sort
   k = slist.Count
   ReDim arr2(1 To a, 1 To 8)
   For i = 0 To k - 1
       a = olit.InDexOf(slist(i), 0) + 1
       For j = 1 To 8
           arr2(i + 1, j) = arr1(a, j)
      Next j
   Next i
   With Sheets("lan 1")
       .Range("A3").Resize(k, 8).Value = arr2
   End With
End Sub
Cách hướng dẫn của snow25 thường thì gọi là hướng dẫn "trọc"
Chỉ phù hợp với các bạn đã biết nhiều về VBA. Tốt nhất là bạn nên đưa code vào file XL. Nếu có thời gian thì giải thích cho bạn ấy chút ít nữa thì hay.
 
Bạn xem code.Đây là tách theo thi lần 1 nhé.
Mã:
Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
        Dim VB As Object
        Set VB = CreateObject("VBScript.regexp")
             VB.Global = True
             VB.Pattern = "\" & dk
            doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi()
    Dim arr, arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
    Set slist = CreateObject("System.Collections.ArrayList")
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
        ReDim arr1(1 To UBound(arr, 1), 1 To 9)
        For i = 1 To UBound(arr, 1)
            If Len(arr(i, 3)) = 0 Then
               If Len(arr(i + 1, 3)) = 0 Then
                  a = a + 1
                  mon = arr(i, 1)
                  arr1(a, 1) = mon
                  arr1(a, 2) = arr(i + 1, 1)
                  i = i + 1
                Else
                   a = a + 1
                   arr1(a, 1) = mon
                   arr1(a, 2) = arr(i, 1)
                End If
            Else
               If UCase(arr(i, 1)) = "THI L" & ChrW(7846) & "N 1" Then
                  arr1(a, 3) = "THI L" & ChrW(7846) & "N 1"
                  For j = 5 To 8
                      arr1(a, j) = arr(i, j - 2)
                  Next j
                  so = CDate(doingay(arr(i, 4), "h", ":"))
                  arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
                  slist.Add arr1(a, 9)
               End If
           End If
       Next i
   End With
   Set olit = slist.Clone
   slist.Sort
   k = slist.Count
   ReDim arr2(1 To a, 1 To 8)
   For i = 0 To k - 1
       a = olit.InDexOf(slist(i), 0) + 1
       For j = 1 To 8
           arr2(i + 1, j) = arr1(a, j)
      Next j
   Next i
   With Sheets("lan 1")
       .Range("A3").Resize(k, 8).Value = arr2
   End With
End Sub
Chào anh/chị mình không biết làm thế nào, giúp mình chi tiết được không. Mình cảm ơn
 
Chào anh/chị mình không biết làm thế nào, giúp mình chi tiết được không. Mình cảm ơn
Đây bạn xem.Chỉ cần click vào là được.
Mã:
Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
        Dim VB As Object
        Set VB = CreateObject("VBScript.regexp")
             VB.Global = True
             VB.Pattern = "\" & dk
            doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi(ByVal arr, ByVal dk As String, ByVal ten As String)
    Dim arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
    Set slist = CreateObject("System.Collections.ArrayList")
        ReDim arr1(1 To UBound(arr, 1), 1 To 9)
        For i = 1 To UBound(arr, 1)
            If Len(arr(i, 3)) = 0 Then
               If Len(arr(i + 1, 3)) = 0 Then
                  a = a + 1
                  mon = arr(i, 1)
                  arr1(a, 1) = mon
                  arr1(a, 2) = arr(i + 1, 1)
                  i = i + 1
                Else
                   a = a + 1
                   arr1(a, 1) = mon
                   arr1(a, 2) = arr(i, 1)
                End If
            Else
               If UCase(arr(i, 1)) = dk Then
                  arr1(a, 3) = dk
                  For j = 5 To 8
                      arr1(a, j) = arr(i, j - 2)
                  Next j
                  so = CDate(doingay(arr(i, 4), "h", ":"))
                  arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
                  slist.Add arr1(a, 9) & arr1(a, 2)
               End If
           End If
       Next i
   Set olit = slist.Clone
   slist.Sort
   k = slist.Count
   ReDim arr2(1 To a, 1 To 8)
   For i = 0 To k - 1
       a = olit.InDexOf(slist(i), 0) + 1
       For j = 1 To 8
           arr2(i + 1, j) = arr1(a, j)
      Next j
   Next i
   With Sheets(ten)
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 3 Then .Range("A3:H" & lr).ClearContents
       .Range("a3").Resize(k, 8).Value = arr2
   End With
End Sub
Sub tachlan1()
Dim lr As Long, arr, arr2
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
    End With
 chuyendoi arr, "THI L" & ChrW(7846) & "N 1", "lan 1"
End Sub
Sub tachlan2()
Dim lr As Long, arr, arr2
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
    End With
 chuyendoi arr, "THI L" & ChrW(7846) & "N 2", "lan 2"
End Sub
 

File đính kèm

  • lich thi (1).xls
    72.5 KB · Đọc: 6
Đây bạn xem.Chỉ cần click vào là được.
Mã:
Function doingay(ByVal ngay As String, ByVal dk As String, Optional phancach As String = ":")
        Dim VB As Object
        Set VB = CreateObject("VBScript.regexp")
             VB.Global = True
             VB.Pattern = "\" & dk
            doingay = VB.Replace(ngay, phancach)
End Function
Sub chuyendoi(ByVal arr, ByVal dk As String, ByVal ten As String)
    Dim arr1, arr2, i As Long, j As Long, lr As Long, so As Double, a As Long, mon As String, slist As Object, k As Long, olit As Object
    Set slist = CreateObject("System.Collections.ArrayList")
        ReDim arr1(1 To UBound(arr, 1), 1 To 9)
        For i = 1 To UBound(arr, 1)
            If Len(arr(i, 3)) = 0 Then
               If Len(arr(i + 1, 3)) = 0 Then
                  a = a + 1
                  mon = arr(i, 1)
                  arr1(a, 1) = mon
                  arr1(a, 2) = arr(i + 1, 1)
                  i = i + 1
                Else
                   a = a + 1
                   arr1(a, 1) = mon
                   arr1(a, 2) = arr(i, 1)
                End If
            Else
               If UCase(arr(i, 1)) = dk Then
                  arr1(a, 3) = dk
                  For j = 5 To 8
                      arr1(a, j) = arr(i, j - 2)
                  Next j
                  so = CDate(doingay(arr(i, 4), "h", ":"))
                  arr1(a, 9) = CLng(CDate(doingay(arr(i, 3), ".", "-"))) + so
                  slist.Add arr1(a, 9) & arr1(a, 2)
               End If
           End If
       Next i
   Set olit = slist.Clone
   slist.Sort
   k = slist.Count
   ReDim arr2(1 To a, 1 To 8)
   For i = 0 To k - 1
       a = olit.InDexOf(slist(i), 0) + 1
       For j = 1 To 8
           arr2(i + 1, j) = arr1(a, j)
      Next j
   Next i
   With Sheets(ten)
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 3 Then .Range("A3:H" & lr).ClearContents
       .Range("a3").Resize(k, 8).Value = arr2
   End With
End Sub
Sub tachlan1()
Dim lr As Long, arr, arr2
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
    End With
chuyendoi arr, "THI L" & ChrW(7846) & "N 1", "lan 1"
End Sub
Sub tachlan2()
Dim lr As Long, arr, arr2
    With Sheets("du lieu")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 5 Then Exit Sub
        arr = .Range("A3:F" & lr).Value
    End With
chuyendoi arr, "THI L" & ChrW(7846) & "N 2", "lan 2"
End Sub
Mình cảm ơn nhiều, chuẩn luôn. Chỉ mỗi môn nào không có ngày thi thì bị lỗi (xóa tay vậy). Một lần nữa cảm ơn bạn nhiều.
 
Web KT
Back
Top Bottom