Xin được giúp đỡ về tổng hợp thời khóa biểu (1 người xem)

hochoi29 · 9/10/10

Xin được giúp đỡ về một vấn đề thời khóa biểu trong excel!

Chào mọi người!
Xin được mọi người giúp đỡ vần đề này ạ!
Có một sheet TKB sáng và sheet TKB chiều từ đó tổng hợp thành TKB tổng hợp. (xem file đính kèm).
Làm sau để lấy kết quả bằng một công thức duy nhất hay đoạn mã VBA để xử lí vấn đề này.
Trân trọng cảm ơn!

adua29 · 9/10/10

Bạn xem file kèm theo xem đã đạt yêu cầu chưa, có gì trao đổi tiếp nhé

hochoi29 · 13/10/10

Cảm ơn adua29 nhiều!
Như vậy là ổn rồi!

SA_DQ · 13/10/10

Thêm 1 tham khảo bằng macro

PHP:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [f2]) Is Nothing Then
    Dim jJ As Byte

   [a2].Resize(99, 4).Clear
   If Left([f2], 1) = "T" Then
      GPE [f2].Value
   Else
      For jJ = 2 To 7
         GPE Mid([f2].Value, 5, 5) & " " & jJ
      Next jJ
   End If
 End If
End Sub

Mã:

Sub GPE(Thú As String)
   Dim Sh As Worksheet, Rng As Range, sRng As Range
   Dim ShN As String:                  Dim jJ As Byte
   
   For jJ = 1 To 2
      ShN = Choose(jJ, "Sang", "Chieu")
      Set Sh = Sheets(ShN)
      Set Rng = Sh.Range(Sh.[B1], Sh.[b99].End(xlUp))
      Set sRng = Rng.Find(Thú, , xlFormulas, xlWhole)
      With [B65500].End(xlUp).Offset(1)
         If jJ = 2 Then
            .Offset(, -1) = Thú
            .Offset(, -1).Interior.ColorIndex = 34 + .Row Mod 7
         End If
         .Resize(5, 3).Value = sRng.Offset(-2, 1).Resize(5, 3).Value
      End With
   Next jJ
[B]End Sub[/B]

concogia · 13/10/10

hochoi29 đã viết:
Chào mọi người!
Xin được mọi người giúp đỡ vần đề này ạ!
Có một sheet TKB sáng và sheet TKB chiều từ đó tổng hợp thành TKB tổng hợp. (xem file đính kèm).
Làm sau để lấy kết quả bằng một công thức duy nhất hay đoạn mã VBA để xử lí vấn đề này.
Trân trọng cảm ơn!

Một cách tổng hợp dễ nhìn một tý:

Mã:

Public Sub LOC()
    Dim WsS, WsC, VungS, VungC, I, J, M
    Range("h7:m16").ClearContents
        Set WsS = Sheets("TKB sang"): Set WsC = Sheets("TKB chieu")
        Set VungS = WsS.Range("b2:b36"): Set VungC = WsC.Range("b2:b36")
            For I = 1 To 6
                For J = 1 To 5
                    If VungS(J + M).Offset(0, 1) <> "" Then Cells(6 + J, 7 + I) = VungS(J + M).Offset(0, 1) & "- " & VungS(J + M).Offset(0, 2)
                    If VungC(J + M).Offset(0, 1) <> "" Then Cells(11 + J, 7 + I) = VungC(J + M).Offset(0, 1) & "- " & VungC(J + M).Offset(0, 2)
                Next
                M = M + 5
            Next
End Sub

Nhập dữ liệu xong, qua sheet tong hop bấm nút

hochoi29 · 29/10/10

Xin được cảm ơn mọi người đã hỗ trợ về vấn đề này!
Nay tôi xin được hỏi thêm:
Tôi có một sheet phân công chuyên môn, một sheet thời khóa biểu toàn trường, bây giờ muốn tạo ra thời khóa biểu của từng giáo viên một. (file dữ liệu đính kèm)
Vậy xin mọi người chỉ giáo!
Trân trọng cảm ơn!

huuthang_bd · 29/10/10

hochoi29 đã viết:
Xin được cảm ơn mọi người đã hỗ trợ về vấn đề này!
Nay tôi xin được hỏi thêm:
Tôi có một sheet phân công chuyên môn, một sheet thời khóa biểu toàn trường, bây giờ muốn tạo ra thời khóa biểu của từng giáo viên một. (file dữ liệu đính kèm)
Vậy xin mọi người chỉ giáo!
Trân trọng cảm ơn!

Bạn xem trong file. Tôi dùng công thức.

Lưu ý:
- Dữ liệu trong sheet PCCM của bạn chưa chuẩn. Có 2 dòng Thầy Phúc dạy lý lớp 9/1 và hai dòng thầy Phúc dạy Công nghệ lớp 9/2.
- Để công thức trong file không bị sai thì Dữ liệu trong Sheet PCCM phải là duy nhất (không có các trường hợp hai dòng giống nhau như trên) và dữ liệu phải được sắp sếp theo tên giáo viên và tên môn học.

thanh_tks · 29/10/10

hochoi29 đã viết:
Xin được cảm ơn mọi người đã hỗ trợ về vấn đề này!
Nay tôi xin được hỏi thêm:
Tôi có một sheet phân công chuyên môn, một sheet thời khóa biểu toàn trường, bây giờ muốn tạo ra thời khóa biểu của từng giáo viên một. (file dữ liệu đính kèm)
Vậy xin mọi người chỉ giáo!
Trân trọng cảm ơn!

Bạn xem thêm bài này!
Bạn lưu ý! có một vài trường hợp: Hai người cùng dạy một môn và một lớp. Một số môn không có Giáo viên.

hochoi29 · 29/10/10

Tuyệt thật! Xin cảm ơn!
Cái này có thể dùng vba để tùy biến hơn được không ạ? Để không phụ thuộc vào dữ liệu vào là phân công chuyên môn và thời khóa biểu cụ thể!

SA_DQ · 30/10/10

Được, tất nhiên, nhưng

Cái này có thể dùng vba để tùy biến hơn được không ạ? Để không phụ thuộc vào dữ liệu vào là phân công chuyên môn và thời khóa biểu cụ thể!

Nhưng trang tính của bạn mang đầy lỗi chính tả:

Ví dụ: Chữ 'Tin' trong trang TKB Truong' có độ dài là 4;
Chữ 'Văn' ở cột [6/1] của trang này khác font chữ với bên trang 'PCCM'; tuy ta nhìn thấy chúng như 1, nhưng với VBA thì chúng cùng cha, nhưng khác mẹ đó bạn!

Mình fải mất gấp đôi thời gian so với thời gian để viết ra macro nhưng cũng chưa biết vì sao có ngày đến 7 tiết (?)

Chắc trong ngành bạn biết câu của ông bà: "sai con toán bán con trâu!"

Mình nhường bạn chuyện đồng nhứt dữ liệu các trang tính đó thôi!

PHP:

Option Explicit
Sub TKBGiaoVien()
 Dim Col As Byte, Rws As Long
 Dim Sh0 As Worksheet, Sh As Worksheet
 Dim Rng0 As Range, Rng As Range, sRng As Range, Cls As Range
 Dim MHoc As String, MyAdd As String, TenGV As String
 
 Sheets("TKB Truong").Select:       Set Sh = Sheets("PCCM")
 Set Rng = Sh.Range(Sh.[c1], Sh.[c65500].End(xlUp))
 Set Sh0 = Sheets("TKB GV")
 Set Rng0 = Sh0.Range(Sh0.[c1], Sh0.[iV1].End(xlToLeft))
 Sh0.[C2].Resize(Rng.Rows.Count, Rng0.Columns.Count).ClearContents
 For Col = 3 To 8
   For Rws = 4 To 31
      MHoc = Trim(Cells(Rws, Col).Value)
      If MHoc <> "" Then
         Set sRng = Rng.Find(MHoc, , xlFormulas, xlWhole)
         If Not sRng Is Nothing Then
            MyAdd = sRng.Address
            Do
               If sRng.Offset(, -1).Value = Cells(2, Col).Value Then
                  For Each Cls In Rng0
                     If Cls.Value = sRng.Offset(, -2).Value Then
                        Sh0.Cells(Rws - 1, Cls.Column).Value = Cells(2, Col).Value
                     End If
                  Next Cls
               End If
               Set sRng = Rng.FindNext(sRng)
            Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
         End If
      End If
   Next Rws
 Next Col
End Sub

Chúc thành công!

hochoi29 · 30/10/10

Vba này chạy tốt, nhưng sao xử lí lâu quá!
À có thể lấy luôn môn và lớp thì tốt hơn nhỉ!
Xin cảm ơn!

ChanhTQ@ · 30/10/10

Không hiện giây nào luôn, thế mà bảo lâu

(2) Vba này chạy tốt, nhưng sao xử lí lâu quá!
(1) À có thể lấy luôn môn và lớp thì tốt hơn nhỉ!
Xin cảm ơn!

(1) Bạn chỉnh lại dòng lệnh giống vầy => vầy

PHP:

  Sh0.Cells(Rws - 1, Cls.Column).Value = Cells(2, Col).Value & " " & MHoc

(2) Có khi bạn chờ nó, nhưng thực ra nó xong từ lâu rồi mà bạn thì chờ!

Bạn thêm dòng lệnh này vô trước dòng cuối cùng:

Mã:

  Sh0.Select

 [COLOR=plum]End Sub[/COLOR]

ThuNghi · 30/10/10

ChanhTQ@ đã viết:
(1) Bạn chỉnh lại dòng lệnh giống vầy => vầy

PHP:

Sh0.Cells(Rws - 1, Cls.Column).Value = Cells(2, Col).Value & " " & MHoc

(2) Có khi bạn chờ nó, nhưng thực ra nó xong từ lâu rồi mà bạn thì chờ!

Bạn thêm dòng lệnh này vô trước dòng cuối cùng:

Mã:

Sh0.Select [COLOR=plum]End Sub[/COLOR]

Dạng bài này hay quá, nếu tác giả có dữ liệu đẹp thì đó là 1 yêu cầu cần thiết cho các giáo viên.
CN này có chuyện làm rồi. Làm tặng cô giáo.
Bác Sa cùng em làm nhé.

chucuoi92 · 30/10/10

Mình cũng vừa thử code này thấy lần đâu thì nhanh, nhưng lần tiếp thì cũng thấy mất 5 đến 7 giây gì đó!
Dữ liệu của 2 sheet dữ liệu không đồng nhất (có khoảng trắng thừa, do vậy tính toán bị thiếu)

SA_DQ · 30/10/10

Đầu, bạn thử tải cái ni về & bấm liên tục {CTRL}+{SHIFT}+T xem nó báo mấy gy?!

Mình cũng vừa thử code này thấy lần đâu thì nhanh, nhưng lần tiếp thì cũng thấy mất 5 đến 7 giây gì đó!

huuthang_bd · 1/11/10

Chu.cuoi92 đã viết:
Mình cũng vừa thử code này thấy lần đâu thì nhanh, nhưng lần tiếp thì cũng thấy mất 5 đến 7 giây gì đó!
Dữ liệu của 2 sheet dữ liệu không đồng nhất (có khoảng trắng thừa, do vậy tính toán bị thiếu)

Thử cái này xem có nhanh hơn không. Dữ liệu phải chuẩn thì mới xài được nha.

PHP:

Sub ThoiKhoaBieu()
Dim Dic, Arr, DSGV As Range, KetQua(1 To 250, 1 To 250), c As Long, r As Long, i As Long, Str As String
Arr = Range(Sheet1.[A2], Sheet1.[C65536].End(xlUp)).Value
r = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To r
    Dic.Add Arr(i, 3) & " - " & Arr(i, 2), Arr(i, 1)
Next
Set DSGV = Range(Sheet3.[C1], Sheet3.[IV1].End(xlToLeft))
With Range(Sheet2.[B65536].End(xlUp).Offset(, 1), Sheet2.[IV2].End(xlToLeft))
    r = .Rows.Count:    c = .Columns.Count:    Arr = .Value
End With
    For i = 2 To r
        For j = 1 To c
            Str = Arr(i, j) & " - " & Arr(1, j)
            If Dic.Exists(Str) Then KetQua(i - 1, Application.WorksheetFunction.Match(Dic.Item(Str), DSGV, 0)) = Str
        Next j
    Next i
DSGV.Offset(1).Resize(r - 1).Value = KetQua()
End Sub

ThuNghi · 1/11/10

huuthang_bd đã viết:

Thử cái này xem có nhanh hơn không. Dữ liệu phải chuẩn thì mới xài được nha.

PHP:

Sub ThoiKhoaBieu()
Dim Dic, Arr, DSGV As Range, KetQua(1 To 250, 1 To 250), c As Long, r As Long, i As Long, Str As String
Arr = Range(Sheet1.[A2], Sheet1.[C65536].End(xlUp)).Value
r = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To r
    Dic.Add Arr(i, 3) & " - " & Arr(i, 2), Arr(i, 1)
Next
Set DSGV = Range(Sheet3.[C1], Sheet3.[IV1].End(xlToLeft))
With Range(Sheet2.[B65536].End(xlUp).Offset(, 1), Sheet2.[IV2].End(xlToLeft))
    r = .Rows.Count:    c = .Columns.Count:    Arr = .Value
End With
    For i = 2 To r
        For j = 1 To c
            Str = Arr(i, j) & " - " & Arr(1, j)
            If Dic.Exists(Str) Then KetQua(i - 1, Application.WorksheetFunction.Match(Dic.Item(Str), DSGV, 0)) = Str
        Next j
    Next i
DSGV.Offset(1).Resize(r - 1).Value = KetQua()
End Sub

Mình thì dùng luôn Dic để lấy DSGV luôn. Hy vọng cũng nhanh.

PHP:

Sub TKB()
Dim i As Long, j As Long, s As Long, endR As Long, endC As Long
Dim Str As String, sTmp As String
Dim Dic1 As Object, Dic2 As Object
Dim Arr, ArrTen, KetQua()
With Sheet1
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr = .Range("A2:C" & endR).Value
End With
s = 0
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr, 1)
  sTmp = Arr(i, 3) & " - " & Arr(i, 2)
  If Not Dic1.Exists(sTmp) Then
    Dic1.Add sTmp, Arr(i, 1)
  End If
  If Not Dic2.Exists(Arr(i, 1)) Then
    s = s + 1
    Dic2.Add Arr(i, 1), s
  End If
Next i
ArrTen = Dic2.Keys
With Sheet2
  endR = .Cells(65000, 2).End(xlUp).Row - 1
  endC = .Cells(2, 256).End(xlToLeft).Column - 2
  Arr = .Range("C2").Resize(endR, endC).Value
End With
ReDim KetQua(1 To UBound(Arr, 1), 1 To Dic2.Count)
For i = 2 To UBound(Arr, 1)
  For j = 1 To UBound(Arr, 2)
    Str = Arr(i, j) & " - " & Arr(1, j)
    If Dic1.Exists(Str) Then
      KetQua(i - 1, Dic2.Item(Dic1.Item(Str))) = Str
    End If
  Next j
Next i
With Sheet3.Range("C1")
  .Resize(1000, 250).ClearContents
  .Resize(, Dic2.Count).Value = ArrTen
  .Offset(1, 0).Resize(i - 1, Dic2.Count).Value = KetQua
End With
Erase Arr, ArrTen, KetQua()
Set Dic1 = Nothing: Set Dic2 = Nothing
End Sub

hochoi29 · 22/11/10

Xin cảm ơn về những giúp đỡ hết sức đầy đủ, nhiệt tình của mọi người!
Tôi đang làm về cái thời khóa biểu nên khi bí thì hỏi lần tới, mong sự giúp đỡ của mọi người!
Lần này xin được giúp đỡ theo dữ liệu của file đính kèm sau.
Xin cảm ơn!

boyxin · 22/11/10

Em xin góp vui 1 file để tham khảo (hiện tại em đang dùng)

_________________________________________________
t/b: Nói nhỏ là trong sheet có protect nhưng không có Pwd

hochoi29 · 26/11/10

Nhờ boyxin xem giúp giải quyết trường hợp riêng đó ạ! (file Demo_lbg)
Xin cảm ơn!

Xin được giúp đỡ về tổng hợp thời khóa biểu (1 người xem)

Người dùng đang xem chủ đề này

Thành viên mới

File đính kèm

Real-life Girls Super Сasual Dating

File đính kèm

Thành viên mới

/(hông là gì!

File đính kèm

Gội rồi mới Cạo

File đính kèm

Thành viên mới

File đính kèm

Chuyên gia GPE

File đính kèm

Khó khăn biết dũng khí.

File đính kèm

Thành viên mới

/(hông là gì!

Thành viên mới

0901452không62

Hãy cho rồi sẽ nhận!

Thành viên lười biếng

/(hông là gì!

File đính kèm

Chuyên gia GPE

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên mới

File đính kèm

Members actively

File đính kèm

Thành viên mới

Đếm ngược thời gian