Chuyển hàng thành cột (1 người xem)

aviaiva · 8/6/12

Nhờ các bác cao thủ giúp đỡ giải hộ bài toán sau bằng VBA càng tốt

trong quá trình phân công lớp cho giáo viên theo hàng ngang mình muốn chuyển thành hàng dọc để dễ nhìn và dễ kiểm tra xem ai chưa được xếp.

Nếu xuất hiện trường hợp 2 giáo viên cùng lớp ví dụ GiaoV 12A1, phượngV cũng 12A1 thì cột dọc sẽ hiển thị
GiaoV, PhượngV như hình trên.

download file đính kèm

concogia · 8/6/12

aviaiva đã viết:
Nhờ các bác cao thủ giúp đỡ giải hộ bài toán sau bằng VBA càng tốt

trong quá trình phân công lớp cho giáo viên theo hàng ngang mình muốn chuyển thành hàng dọc để dễ nhìn và dễ kiểm tra xem ai chưa được xếp.

Nếu xuất hiện trường hợp 2 giáo viên cùng lớp ví dụ GiaoV 12A1, phượngV cũng 12A1 thì cột dọc sẽ hiển thị
GiaoV, PhượngV như hình trên.

download file đính kèm

Mã:

Thử với code này xem sao, có gì bàn tiếp
Thân
Public Sub Chuyen()
    Dim Vung, Mg, I, J, M, d, K, Gom, VungDo, Mon, Tach
    Set Vung = [A5].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set VungDo = Range([I5], [I2000].End(xlUp))
    Set Mon = Range([J4], [J4].End(xlToRight))
        For I = 1 To Vung.Rows.Count
            For J = 1 To Vung.Columns.Count
                Gom = Gom & Vung(I, J) & " "
            Next J
                If Not d.exists(Vung(I, 2).Value) Then
                    K = K + 1
                    d.Add Vung(I, 2).Value, Gom
                    Gom = ""
                Else
                    d.Item(Vung(I, 2).Value) = d.Item(Vung(I, 2).Value) & "-" & Gom
                    Gom = ""
                End If
        Next I
                For I = 1 To Mon.Columns.Count
                    Tach = Split(d.Item(Mon(I).Value), "-")
                        For J = 1 To VungDo.Rows.Count
                            For M = LBound(Tach) To UBound(Tach)
                                If InStr(1, Tach(M), VungDo(J)) Then
                                    VungDo(J).Offset(, I) = VungDo(J).Offset(, I) & "- " & Left(Tach(M), InStr(Tach(M), " "))
                                End If
                            Next M
                        Next J
                Next I
End Sub

Chý ú!!!!
Tên các môn học ở 2 bảng phải hoàn toàn giống nhau
Mã tên giáo viên không có khoảng trống
Thân

Quang_Hải · 8/6/12

Góp vui 1 file liên quan đến phân công giáo viên

aviaiva · 8/6/12

concogia đã viết:

Mã:

Thử với code này xem sao, có gì bàn tiếp
Thân
Public Sub Chuyen()
    Dim Vung, Mg, I, J, M, d, K, Gom, VungDo, Mon, Tach
    Set Vung = [A5].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set VungDo = Range([I5], [I2000].End(xlUp))
    Set Mon = Range([J4], [J4].End(xlToRight))
        For I = 1 To Vung.Rows.Count
            For J = 1 To Vung.Columns.Count
                Gom = Gom & Vung(I, J) & " "
            Next J
                If Not d.exists(Vung(I, 2).Value) Then
                    K = K + 1
                    d.Add Vung(I, 2).Value, Gom
                    Gom = ""
                Else
                    d.Item(Vung(I, 2).Value) = d.Item(Vung(I, 2).Value) & "-" & Gom
                    Gom = ""
                End If
        Next I
                For I = 1 To Mon.Columns.Count
                    Tach = Split(d.Item(Mon(I).Value), "-")
                        For J = 1 To VungDo.Rows.Count
                            For M = LBound(Tach) To UBound(Tach)
                                If InStr(1, Tach(M), VungDo(J)) Then
                                    VungDo(J).Offset(, I) = VungDo(J).Offset(, I) & "- " & Left(Tach(M), InStr(Tach(M), " "))
                                End If
                            Next M
                        Next J
                Next I
End Sub

Chý ú!!!!
Tên các môn học ở 2 bảng phải hoàn toàn giống nhau
Mã tên giáo viên không có khoảng trống
Thân

code của bác chuẩn quá không có gì phải bàn, nhưng em áp dụng vào cái thực tế của em sửa đổi vùng dữ liệu nhưng nó không chạy.

Mong bác giúp đỡ!

concogia · 8/6/12

aviaiva đã viết:
code của bác chuẩn quá không có gì phải bàn, nhưng em áp dụng vào cái thực tế của em sửa đổi vùng dữ liệu nhưng nó không chạy.

Mong bác giúp đỡ!

Híc, 2 cái bảng nó hổng có giống nhau gì ráo
Bạn thử kiểm tra code này:

Mã:

Public Sub Chuyen()
Application.ScreenUpdating = False
Range("u5:ag1000").ClearContents
    Dim Vung, Mg, I, J, M, d, K, Gom, VungDo, Mon, Tach
    Set Vung = Range([B4], [B5000].End(xlUp)).Resize(, 10)
    Set d = CreateObject("scripting.dictionary")
    Set VungDo = Range([AH4], [AH2000].End(xlUp))
    Set Mon = Range("u3:ag3")
        For I = 1 To Vung.Rows.Count
            For J = 1 To Vung.Columns.Count
                Gom = Gom & Vung(I, J) & " "
            Next J
                If Not d.exists(Vung(I, 2).Value) Then
                    K = K + 1
                    d.Add Vung(I, 2).Value, Gom
                    Gom = ""
                Else
                    d.Item(Vung(I, 2).Value) = d.Item(Vung(I, 2).Value) & "-" & Gom
                    Gom = ""
                End If
        Next I
                For I = 1 To Mon.Columns.Count
                    Tach = Split(d.Item(Mon(I).Value), "-")
                        For J = 1 To VungDo.Rows.Count
                            For M = LBound(Tach) To UBound(Tach)
                                If InStr(1, Tach(M), VungDo(J)) Then
                                    VungDo(J).Offset(, -14 + I) = VungDo(J).Offset(, -14 + I) & "- " & Left(Tach(M), InStr(Tach(M), " "))
                                End If
                            Next M
                        Next J
                Next I
Application.ScreenUpdating = True
End Sub

Cái này nói ngoài lề thôi nhé, hổng trúng thì bỏ qua: Mã Giáo viên không nên có dấu tiếng Việt, đỡ rắc rối khi dùng code
Thân

aviaiva · 8/6/12

concogia đã viết:

Híc, 2 cái bảng nó hổng có giống nhau gì ráo
Bạn thử kiểm tra code này:

Mã:

Public Sub Chuyen()
Application.ScreenUpdating = False
Range("u5:ag1000").ClearContents
    Dim Vung, Mg, I, J, M, d, K, Gom, VungDo, Mon, Tach
    Set Vung = Range([B4], [B5000].End(xlUp)).Resize(, 10)
    Set d = CreateObject("scripting.dictionary")
    Set VungDo = Range([AH4], [AH2000].End(xlUp))
    Set Mon = Range("u3:ag3")
        For I = 1 To Vung.Rows.Count
            For J = 1 To Vung.Columns.Count
                Gom = Gom & Vung(I, J) & " "
            Next J
                If Not d.exists(Vung(I, 2).Value) Then
                    K = K + 1
                    d.Add Vung(I, 2).Value, Gom
                    Gom = ""
                Else
                    d.Item(Vung(I, 2).Value) = d.Item(Vung(I, 2).Value) & "-" & Gom
                    Gom = ""
                End If
        Next I
                For I = 1 To Mon.Columns.Count
                    Tach = Split(d.Item(Mon(I).Value), "-")
                        For J = 1 To VungDo.Rows.Count
                            For M = LBound(Tach) To UBound(Tach)
                                If InStr(1, Tach(M), VungDo(J)) Then
                                    VungDo(J).Offset(, -14 + I) = VungDo(J).Offset(, -14 + I) & "- " & Left(Tach(M), InStr(Tach(M), " "))
                                End If
                            Next M
                        Next J
                Next I
Application.ScreenUpdating = True
End Sub

Cái này nói ngoài lề thôi nhé, hổng trúng thì bỏ qua: Mã Giáo viên không nên có dấu tiếng Việt, đỡ rắc rối khi dùng code
Thân

Hi! thực ra em chỉ có ý tưởng thôi, còn viết code thì chưa đủ trình.
Phần lớn code em viết là for i = to ...
if thỏa mãn thì copy
thế nên tiếng nào cũng oke hết.

có mỗi cái phần chuyển hàng thành cột này thì chịu không sao cho nó gọn được.

rất cảm ơn bác concogia

aviaiva · 8/6/12

còn một phần nhỏ nữa mong các bác giúp đỡ đó là chuyển từ thời khóa biểu giáo viên sang TKB học sinh.

em cũng làm được bằng VBA rồi nhưng em cho 3 hàm for chạy nên nó hơi chậm nếu nhiều lớp

mong bác giúp đỡ em cải thiện cái code chuyển.

em xin cám ơn lắm lắm.

Bảng TKB giáo viên của em như sau

bảng TKB học sinh của em như sau

code của em đã dùng như sau

PHP:

Sub TKBHS()
Application.ScreenUpdating = False
Sheets("tkbhs").Range("c4:by33").ClearContents
 R = Application.CountA(Sheets("tkbhs").Range("a3:by3")) + 1
 For u = 3 To Application.CountA(Sheets("tkbhs").Range("a3:bx3")) + 1
 If Sheets("tkbhs").Cells(3, u) <> "" Then
 K = 4
 For I = 4 To 33
     For J = 4 To Application.CountA(Sheets("tkb").Range("c4:c304")) + 16
         If Sheets("tkb").Cells(J, I) = Sheets("Tkbhs").Cells(3, u) Then
         Sheets("tkb").Select
         Sheets("tkb").Cells(J, 3).Copy
         Sheets("tkbhs").Select
         Cells(K, u).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Else
        End If
      Next J
        K = K + 1
  Next I
          Application.StatusBar = "dang thuc hien: " & WorksheetFunction.Round(u / R * 100, 1) & "%"
          Else
  End If
  Next u
  Sheets("tkbhs").Select
  Cells(3, 4).Select
  Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

ms_office · 8/6/12

Cho em hỏi cách đưa code VBA vào Excel như nào vậy, em thấy các anh chia sẻ code mà em chưa biết áp dụng như nào cả.

concogia · 9/6/12

aviaiva đã viết:
còn một phần nhỏ nữa mong các bác giúp đỡ đó là chuyển từ thời khóa biểu giáo viên sang TKB học sinh.

em cũng làm được bằng VBA rồi nhưng em cho 3 hàm for chạy nên nó hơi chậm nếu nhiều lớp

mong bác giúp đỡ em cải thiện cái code chuyển.

em xin cám ơn lắm lắm.

Bảng TKB giáo viên của em như sau

bảng TKB học sinh của em như sau

code của em đã dùng như sau

PHP:

Sub TKBHS() Application.ScreenUpdating = False Sheets("tkbhs").Range("c4:by33").ClearContents R = Application.CountA(Sheets("tkbhs").Range("a3:by3")) + 1 For u = 3 To Application.CountA(Sheets("tkbhs").Range("a3:bx3")) + 1 If Sheets("tkbhs").Cells(3, u) <> "" Then K = 4 For I = 4 To 33 For J = 4 To Application.CountA(Sheets("tkb").Range("c4:c304")) + 16 If Sheets("tkb").Cells(J, I) = Sheets("Tkbhs").Cells(3, u) Then Sheets("tkb").Select Sheets("tkb").Cells(J, 3).Copy Sheets("tkbhs").Select Cells(K, u).Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Else End If Next J K = K + 1 Next I Application.StatusBar = "dang thuc hien: " & WorksheetFunction.Round(u / R * 100, 1) & "%" Else End If Next u Sheets("tkbhs").Select Cells(3, 4).Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Muốn xử lý nhanh những dạng bài thế này bạn phải sử dụng mảng
Bạn thử chạy code này & so sánh tốc độ với code của bạn xem sao

Mã:

Public Sub Tkb()
    Dim Vung, I, J, Mg, Lop, Mon
    Vung = Range([C4], [C1000].End(xlUp)).Offset(, 1).Resize(, 31)
    Set Lop = Sheets("TKBHS").Range(Sheets("TKBHS").[C3], Sheets("TKBHS").[C3].End(xlToRight))
    Set Mon = Range([C4], [C1000].End(xlUp))
    ReDim Mg(1 To 30, 1 To Lop.Columns.Count)
        For I = 1 To 30
            For J = 1 To UBound(Vung)
                If Vung(J, I) <> "" Then Mg(I, Application.WorksheetFunction.Match(Vung(J, I), Lop, 0)) = Mon(J)
            Next J
        Next I
    Sheets("TKBHS").[V4].Resize(30, Lop.Columns.Count) = Mg
End Sub

Thân

aviaiva · 9/6/12

cảm ơn bác, nhanh không thể tả được gần như là ngay lập tức

aviaiva · 10/11/12

code chuyenhangthanhcot của bác concogia bị lỗi khi tên lớp có số trùng nhau
ví dụ: lớp 12C1 và lớp 12C11 vẫn bị báo trùng, nhờ bác kiểm tra giúp lại

concogia · 12/11/12

aviaiva đã viết:
code chuyenhangthanhcot của bác concogia bị lỗi khi tên lớp có số trùng nhau
ví dụ: lớp 12C1 và lớp 12C11 vẫn bị báo trùng, nhờ bác kiểm tra giúp lại

Bạn kiểm tra lại giúp mình nhé
(Thứ 7 & Chủ nhật là 2 ngày mình.....đâu có tỉnh mà sửa cho bạn. Híc)
Thân

aviaiva · 12/11/12

concogia đã viết:
Bạn kiểm tra lại giúp mình nhé
(Thứ 7 & Chủ nhật là 2 ngày mình.....đâu có tỉnh mà sửa cho bạn. Híc)
Thân

em cảm ơn bác nhiều, nguyên nhân mầu vàng hay quá

Chuyển hàng thành cột (1 người xem)

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

aviaiva

Thành viên thường trực

concogia

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

File đính kèm

Quang_Hải

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

aviaiva

Thành viên thường trực

File đính kèm

concogia

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

aviaiva

Thành viên thường trực

aviaiva

Thành viên thường trực

File đính kèm

ms_office

Thành viên mới

concogia

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

aviaiva

Thành viên thường trực

aviaiva

Thành viên thường trực

File đính kèm

concogia

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

File đính kèm

aviaiva

Thành viên thường trực

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

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

Đếm ngược thời gian