Giúp code chèn mã phòng thi cho khoảng 14 ngàn HS

titanic20072007

Thành viên hoạt động
Tham gia ngày
10 Tháng bảy 2007
Bài viết
196
Được thích
7
Điểm
670
Nơi ở
Hà Nam
Chào các bạn. Hôm nay mình có tình huống nhờ các bạn giúp code để chạy nhanh hơn công thức. Cụ thể:
Trong bảng ở Sheet1: Mỗi trường có nhiều phòng thi. Mỗi phòng thi có mã phòng riêng. Cần chèn mã phòng thi ở Sheet1 vào từng HS ở Sheet2 sao cho HS của trường nào, ở phòng nào thì điền mã phòng tương ứng ở Sheet1. Có tệp đính kèm. Cảm ơn các bạn.
 

File đính kèm

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
Chào các bạn. Hôm nay mình có tình huống nhờ các bạn giúp code để chạy nhanh hơn công thức. Cụ thể:
Trong bảng ở Sheet1: Mỗi trường có nhiều phòng thi. Mỗi phòng thi có mã phòng riêng. Cần chèn mã phòng thi ở Sheet1 vào từng HS ở Sheet2 sao cho HS của trường nào, ở phòng nào thì điền mã phòng tương ứng ở Sheet1. Có tệp đính kèm. Cảm ơn các bạn.
Mã:
Sub lamdai()
Dim Arr1, Arr2, dic As Object, Ten As String, Row1&, phong&, RowAll&
    Set dic = CreateObject("scripting.dictionary")
    RowAll = Sheet2.[B65000].End(xlUp).row
    Arr1 = Sheet1.Range("B5:S28").Value
    Arr2 = Sheet2.Range("B7:J" & RowAll).Value
    For i = 1 To UBound(Arr1)
        If Not dic.exists(dk) Then
        dic.Add Arr1(i, 1), i
        End If
    Next i
    For i = 1 To UBound(Arr2)
        Ten = Arr2(i, 1)
        Row1 = dic.Item(Ten)
        If Ten = Arr1(Row1, 1) Then
            phong = Arr2(i, 2)
            Arr2(i, 9) = Arr1(Row1, 4 + phong)
        End If
    Next i
   With Sheets("sheet2")
        .Range("B7").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
   End With
  Set dic = Nothing
  Erase Arr1
  Erase Arr2
End Sub
làm đại thử coi đúng không
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,505
Được thích
12,206
Điểm
1,560
Mã:
Sub lamdai()
Dim Arr1, Arr2, dic As Object, Ten As String, Row1&, phong&, RowAll&
    Set dic = CreateObject("scripting.dictionary")
    RowAll = Sheet2.[B65000].End(xlUp).row
    Arr1 = Sheet1.Range("B5:S28").Value
    Arr2 = Sheet2.Range("B7:J" & RowAll).Value
    For i = 1 To UBound(Arr1)
        If Not dic.exists(dk) Then
        dic.Add Arr1(i, 1), i
        End If
    Next i
    For i = 1 To UBound(Arr2)
        Ten = Arr2(i, 1)
        Row1 = dic.Item(Ten)
        If Ten = Arr1(Row1, 1) Then
            phong = Arr2(i, 2)
            Arr2(i, 9) = Arr1(Row1, 4 + phong)
        End If
    Next i
   With Sheets("sheet2")
        .Range("B7").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
   End With
  Set dic = Nothing
  Erase Arr1
  Erase Arr2
End Sub
làm đại thử coi đúng không
Giả dụ cột A, B, C sheet2 chưa có,thử làm luôn 3 cột nầy :p
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
Mã:
Sub lamdai()
Dim Arr1, Arr2(), dic As Object, Ten As String, Row1&, phong&, RowAll&, Tongsophong&, x&, xphong&, SoRow&
    Set dic = CreateObject("scripting.dictionary")
    RowAll = Sheet2.[B65000].End(xlUp).row
    Arr1 = Sheet1.Range("B5:S28").Value
    SoRow = 1
    ReDim Arr2(1 To 152, 1 To 9)
    For i = 1 To UBound(Arr1)
        If Not dic.exists(dk) Then
        dic.Add Arr1(i, 1), i
        Tongsophong = Tongsophong + Arr1(i, 4)
        xphong = 0
        For x = SoRow To Tongsophong
        SoRow = SoRow + 1
        xphong = xphong + 1
        Arr2(x, 1) = Arr1(i, 1)
        Arr2(x, 2) = xphong
        Next x
        End If
    Next i
    For i = 1 To UBound(Arr2)
        Ten = Arr2(i, 1)
        Row1 = dic.Item(Ten)
        If Ten = Arr1(Row1, 1) Then
            phong = Arr2(i, 2)
            Arr2(i, 9) = Arr1(Row1, 4 + phong)
        End If
    Next i
   With Sheets("sheet2")
        .Range("B7").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
   End With
  Set dic = Nothing
  Erase Arr1
  Erase Arr2
End Sub
làm đại hên xui
Bài đã được tự động gộp:

Tình hình 'phong trào' khai báo biến như vậy là không ổn rồi.. :(
làm biếng gõ @befaint chứ phong trào gì
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
Mã:
Sub lamdai()
Dim Arr1(), Arr2(), dic As Object, dk As String, RowAll As Long, Tongsophong As Long, x As Long, xphong As Long, SoRow As Long
    Set dic = CreateObject("scripting.dictionary")
    RowAll = Sheet2.[B65000].End(xlUp).row
    Arr1 = Sheet1.Range("B5:S28").Value
    SoRow = 1
    ReDim Arr2(1 To 152, 1 To 9)
    For i = 1 To UBound(Arr1)
        Dk=Arr1(i,1)
        If Not dic.exists(dk) Then
            dic.Add Arr1(i, 1), i
            Tongsophong = Tongsophong + Arr1(i, 4)
            xphong = 0
            For x = SoRow To Tongsophong
                SoRow = SoRow + 1
                xphong = xphong + 1
                Arr2(x, 1) = Arr1(i, 1)
                Arr2(x, 2) = xphong
                Arr2(x, 9) = Arr1(i, 4 + xphong)
            Next x
        Else
        Msgbox "Trung du lieu kiem tra lai: " & dk
        Exit sub
        End If
    Next i
   With Sheets("sheet2")
        .Range("B7").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
   End With
  Set dic = Nothing
  Erase Arr1
  Erase Arr2
End Sub
nhét chung trong 1 vòng lập luôn
 
Lần chỉnh sửa cuối:

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,505
Được thích
12,206
Điểm
1,560
Mã:
Sub lamdai()
Dim Arr1, Arr2(), dic As Object, Ten As String, Row1&, phong&, RowAll&, Tongsophong&, x&, xphong&, SoRow&
    Set dic = CreateObject("scripting.dictionary")
    RowAll = Sheet2.[B65000].End(xlUp).row
    Arr1 = Sheet1.Range("B5:S28").Value
    SoRow = 1
    ReDim Arr2(1 To 152, 1 To 9)
    For i = 1 To UBound(Arr1)
        If Not dic.exists(dk) Then
        dic.Add Arr1(i, 1), i
        Tongsophong = Tongsophong + Arr1(i, 4)
        xphong = 0
        For x = SoRow To Tongsophong
        SoRow = SoRow + 1
        xphong = xphong + 1
        Arr2(x, 1) = Arr1(i, 1)
        Arr2(x, 2) = xphong
        Next x
        End If
    Next i
    For i = 1 To UBound(Arr2)
        Ten = Arr2(i, 1)
        Row1 = dic.Item(Ten)
        If Ten = Arr1(Row1, 1) Then
            phong = Arr2(i, 2)
            Arr2(i, 9) = Arr1(Row1, 4 + phong)
        End If
    Next i
   With Sheets("sheet2")
        .Range("B7").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
   End With
  Set dic = Nothing
  Erase Arr1
  Erase Arr2
End Sub
làm đại hên xui
Bài đã được tự động gộp:


làm biếng gõ @befaint chứ phong trào gì
Chạy chuẩn luôn :)
Chỉ thét mét 1 chút:
If Not dic.exists(dk) Then
dk: là gì vậy !$@!!
Bỏ luôn Dic cho gọn :p
 

VetMini

Bàn phiếm qua bàn phím
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
8,357
Được thích
9,734
Điểm
560
Tôi cũng vái trời cho luôn chạy chuẩn. :D
Sắp mã phòng thi mà không có lấy một vốn liếng. Nhờ viết cốt kiếc a-z thế này làm sao kiểm soát nổi 14 ngàn. Lệch lạc một chút tội nghiệp mấy cháu HS.

Mấy công việc này người ta tự làm. Chỉ hỏi một vài chỗ bí thôi.
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
Chạy chuẩn luôn :)
Chỉ thét mét 1 chút:
If Not dic.exists(dk) Then
dk: là gì vậy !$@!!
Bỏ luôn Dic cho gọn :p
dk là tên
cái đó là cái ẩu đó anh :rolleyes: thôi hết hứng rồi. Code hứng thì viết em hết hứng rồi về nấu cơm đây hehehehehe
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
Chạy chuẩn luôn :)
Chỉ thét mét 1 chút:
If Not dic.exists(dk) Then
dk: là gì vậy !$@!!
Bỏ luôn Dic cho gọn :p
Hihi hứng trở lại rồi em đã sửa mà không có máy kiểm tra, anh còn gì góp ý gì nữa không anh (trong delphi không khai báo là nó nhắc riết em quen kiểu làm biếng rồi hihi)
Thank các anh, em nhiều nhé ;)
 
Lần chỉnh sửa cuối:

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,517
Được thích
2,373
Điểm
360
Hihi hứng trở lại rồi em đã sửa mà không có máy kiểm tra, anh còn gì góp ý gì nữa không anh (trong delphi không khai báo là nó nhắc riết em quen kiểu làm biếng rồi hihi)
Thank các anh, em nhiều nhé ;)
Trong vba bạn đặt câu lệnh gì đó ở đầu menu nó cũng nhắc không cho chạy luôn à.
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,505
Được thích
12,206
Điểm
1,560
Hihi hứng trở lại rồi em đã sửa mà không có máy kiểm tra, anh còn gì góp ý gì nữa không anh (trong delphi không khai báo là nó nhắc riết em quen kiểu làm biếng rồi hihi)
Thank các anh, em nhiều nhé ;)
Code trước lệnh "If Not dic.exists(dk) Then" với "dk" không có giá trị, nhưng code vẫn chạy đúng chứng tỏ Dic không cần thiết, nên bỏ không dùng
Dữ liệu sheet1 chỉ là ví dụ, sẽ còn rất nhiều dòng, "Arr1 = Sheet1.Range("B5:S28").Value" sẽ không lấy hết dữ liệu, cần thêm lệnh lấy dòng cuối của sheet1
"ReDim Arr2(1 To 152, 1 To 9)" Cần tính số 152 là số dòng kết quả có thể bằng hàm "application.sum(sheet1.range("E5:E"&dòng cuối sheet1)), kết quả nên tính luôn số thứ tự: "ReDim Arr2(1 To số dòng kết quả, 1 To 10)"
Code với 2 vòng For lồng nhau rất chuẩn, chỉnh lại tý sẽ dể hơn
For i = 1 To UBound(Arr1)
....
For x = 1 To sophong từng trường
 

VetMini

Bàn phiếm qua bàn phím
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
8,357
Được thích
9,734
Điểm
560
...
Code với 2 vòng For lồng nhau rất chuẩn, chỉnh lại tý sẽ dể hơn
For i = 1 To UBound(Arr1)
....
For x = 1 To sophong từng trường
Không biết bạn nói "rất chuẩn" về phuonwg diện nào. Chứ phương diện dùng biến rất luộm thuộm; và kinh nghiệm về vòng lặp chưa đủ.

Mã:
            For x = SoRow To Tongsophong
                SoRow = SoRow + 1 ' cái này thừa, xem bên dưới
                xphong = xphong + 1
                Arr2(x, 1) = Arr1(i, 1)
                Arr2(x, 2) = xphong
                Arr2(x, 9) = Arr1(i, 4 + xphong)
            Next x
            ' chạy đến đây, SoRow luôn luôn bằng x = Tongsophong + 1
            ' trừ phi trước đó SoRow > Tongsophong
Nói chung thì tôi rất sợ code mà không có chú thích.
Khongn có chú thích thì mình đâu biết thực sự người code muốn làm gì. Không biết muốn làm gì thì không sao đoán được giải thuật sai và do vậy code sai theo hay là giải thuật đúng nhưng code không đi theo giải thuật.
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,505
Được thích
12,206
Điểm
1,560
Không biết bạn nói "rất chuẩn" về phuonwg diện nào. Chứ phương diện dùng biến rất luộm thuộm; và kinh nghiệm về vòng lặp chưa đủ.



Nói chung thì tôi rất sợ code mà không có chú thích.
Khongn có chú thích thì mình đâu biết thực sự người code muốn làm gì. Không biết muốn làm gì thì không sao đoán được giải thuật sai và do vậy code sai theo hay là giải thuật đúng nhưng code không đi theo giải thuật.
"Code với 2 vòng For lồng nhau rất chuẩn "
Không qua trường lớp, mới tập viết code chưa có kinh nghiệm mà viết được code như vậy là tốt rồi, theo thời gian cách viết sẽ dần hoàn thiện, quan trọng là phải mạnh dạn viết, đừng sợ sai sợ lộ cái dở của mình, ai cũng qua giai đoạn ban đầu ngơ ngơ
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
[QUOTE
For x = SoRow To Tongsophong
SoRow = SoRow + 1 ' cái này thừa, xem bên dưới
xphong = xphong + 1
Arr2(x, 1) = Arr1(i, 1)
Arr2(x, 2) = xphong
Arr2(x, 9) = Arr1(i, 4 + xphong)
Next x
' chạy đến đây, SoRow luôn luôn bằng x = Tongsophong + 1
' trừ phi trước đó SoRow > Tongsophong
[/QUOTE]
Sao lại bằng được anh
Mã:
            Tongsophong = Tongsophong + Arr1(i, 4)
            xphong = 0
            For x = SoRow To Tongsophong
                SoRow = SoRow + 1
                xphong = xphong + 1
                Arr2(x, 1) = Arr1(i, 1)
                Arr2(x, 2) = xphong
                Arr2(x, 9) = Arr1(i, 4 + xphong)
            Next x
có chú thích thì mình đâu biết thực sự người code muốn làm gì
Ghi chú được thì tốt sau này dễ chỉnh sửa. Tuy nhiên tùy theo mỗi người yêu cầu chủ top làm sao em làm vậy.
Còn chủ top quan tâm code thì tự khắc sẽ tự hỏi. Còn tin tưởng muốn sài hay không là do chủ top (Muốn ăn phải lăn vào bếp mà)
PS: Vì đây là diễn đàn Free và Code Free nên tác giả không đảm bảo tính chính xác của số liệu thế thôi, tác giả chỉ viết theo cách hiểu của tác giả.
 

VetMini

Bàn phiếm qua bàn phím
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
8,357
Được thích
9,734
Điểm
560
...Sao lại bằng được anh...
For x = SoRow To Tongsophong ' sorow = x at the first entry
SoRow = SoRow + 1 ' sorow = x + 1
Mỗi lượt vòng về thì x tăng lên 1. Nếu x <= tongsophong thì bước vào vòng lặp và sorow tăng lên 1, tức là sorow vẫn = x + 1
Lượt cuối cùng x = tongsophong, vẫn bước vào vòng lặp thì sorow = tongsophong + 1
Đến lượt kế đó, x = tongsophong + 1 thì không bước vào vòng lặp nữa, nhưng sorow đã là (x-1) + 1 = tongsophong + 1

Nhìn code thì biết bạn chưa hiểu hết lý thuyết vòng lặp cho nên tôi mách. Chứ bắt bẻ bạn thì được gì.

Còn cái vụ comments của code thì tôi biết là "truyền thống" của diễn đàn này. Người hỏi bài bắt buộc nhập gia tuỳ tục.
 

thuyyeu99

Trùm Nhiều Chuyện
Tham gia ngày
6 Tháng sáu 2008
Bài viết
1,353
Được thích
573
Điểm
860
hihi em hiểu rồi cám ơn anh :wiggle: (cái này gọi là Code dân dã không chỉn chu đây)
 
Top Bottom