VBA การดึงคะแนนต่ำสุด 3 อันดับสุดท้าย

[aueijung]

เรียนอาจารย์ ที่เคารพครับ
ผมเขียน VBA ดังนี้ครับ

Code: Select all

Sub MinLow3_Click()
    Dim directory As String, fileName As String, bookStr As String
    Dim j As Integer, iMin As Double, iCount As Integer, rw As Integer
    Dim r As Range, rFind As Range
    Dim tempBook As Workbook, thsBook As Workbook
    Dim aRR() As Variant
    
    Application.ScreenUpdating = False
    Set thsBook = ThisWorkbook
    
    j = 3 'เริ่มจากแถวที่ 3
    thsBook.Sheets("min").Range("a3:h1000").ClearContents
    
    For Each r In thsBook.Sheets("min").Range("o2:o7")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 10)
            With thsBook.Sheets("min")
                If Application.CountIf(.Columns("r:r"), bookStr) = 0 Then
                    MsgBox "File " & tempBook.Name & " ไม่พบข้อมูลในคอลัมน์ R"
                    Exit Sub
                Else
                    rw = Application.Match(bookStr, .Range("r2:r10000"), 0) - 1
                End If
            End With
            Set tempBook = Workbooks.Open(directory & fileName)
            With tempBook.Sheets("เกรดเฉลี่ย")
              '  .Range("g7:g1000").SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
                .Range("i7:i1000").Value = .Range("g7:g1000").Value
                .Range("i6").Value = "Grade"
                .Range("i6:i1000").RemoveDuplicates Columns:=1, Header:=xlYes
                iMin = Application.WorksheetFunction.Min(.Range("i7:i1000"), 3)
                iCount = Application.CountIf(.Range("g7:g1000"), ">=" & iMin)
                ReDim aRR(0 To iCount, 1 To 7)
                i = 0
                For Each rFind In .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
                    If rFind.Value >= iMin Then
                        aRR(i, 1) = tempBook.Name 'ชื่อไฟล์
                        aRR(i, 2) = rFind.Offset(0, -4).Value 'รหัสนักเรียน
                        aRR(i, 3) = rFind.Offset(0, -2).Value 'คำนำหน้าชื่อ  ชื่อ
                        aRR(i, 4) = rFind.Offset(0, -1).Value 'นามสกุล
'                        aRR(i, 5) = tempBook.Sheets("Main").Range("B2").Value 'ชั้น
                        aRR(i, 6) = rFind.Value 'คะแนน
                        aRR(i, 7) = rFind.Offset(0, -5).Value 'เลขที่
                        i = i + 1
                    End If
                Next rFind
            End With
            
            thsBook.Sheets("min").Range("a" & j).Resize(iCount, 7).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("ได้รับข้อมูลจาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

ที่ Module2 ครับ ได้ข้อมูลทุกคนเลยครับ แต่คะแนน 3 อันดับสุดท้ายไม่แสดง เราจะปรับโค๊ดแบบใดได้บ้างครับ
ความต้องการของเราคือ ให้แสดงคะแนน 3 ลำดับสุดท้ายเท่านั้น เมื่อเรากดปุ่ม ดึง Mark Min 3 อันดับสุดท้าย ที่ชีท Min ครับ
ชื่อไฟล์ที่ใช้ดึงครับ Mark-Max3Level-and-Min3Level-T2-Y2563-คะแนนสูงสุด-3-อันดับแรกและต่ำสุด 3 อันดับสุดท้าย.xlsm
วางโฟลเด้อ ปพ.5 ไว้ที่ D:\ ครับ

[aueijung]

ผมลองปรับดูแล้วได้ครับ ใช้ Small แทน

Code: Select all

Sub MinLow3_Click()
    Dim directory As String, fileName As String, bookStr As String
    Dim j As Integer, iMin As Double, iCount As Integer, rw As Integer
    Dim r As Range, rFind As Range
    Dim tempBook As Workbook, thsBook As Workbook
    Dim aRR() As Variant
    
    Application.ScreenUpdating = False
    Set thsBook = ThisWorkbook
    
    j = 3 'เริ่มจากแถวที่ 3
    thsBook.Sheets("min").Range("a3:h1000").ClearContents
    
    For Each r In thsBook.Sheets("min").Range("o2:o7")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 10)
            With thsBook.Sheets("min")
                If Application.CountIf(.Columns("r:r"), bookStr) = 0 Then
                    MsgBox "File " & tempBook.Name & " ไม่พบข้อมูลในคอลัมน์ R"
                    Exit Sub
                Else
                    rw = Application.Match(bookStr, .Range("r2:r10000"), 0) - 1
                End If
            End With
            Set tempBook = Workbooks.Open(directory & fileName)
            With tempBook.Sheets("เกรดเฉลี่ย")
              '  .Range("g7:g1000").SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
                .Range("i7:i1000").Value = .Range("g7:g1000").Value
                .Range("i6").Value = "Grade"
                .Range("i6:i1000").RemoveDuplicates Columns:=1, Header:=xlYes
                iMin = Application.WorksheetFunction.Small(.Range("i7:i1000"), 3)
                iCount = Application.CountIf(.Range("g7:g1000"), "<=" & iMin)
                ReDim aRR(0 To iCount, 1 To 7)
                i = 0
                For Each rFind In .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
                    If rFind.Value <= iMin and rFind.Value > 0 Then
                        aRR(i, 1) = tempBook.Name 'ชื่อไฟล์
                        aRR(i, 2) = rFind.Offset(0, -4).Value 'รหัสนักเรียน
                        aRR(i, 3) = rFind.Offset(0, -2).Value 'คำนำหน้าชื่อ  ชื่อ
                        aRR(i, 4) = rFind.Offset(0, -1).Value 'นามสกุล
'                        aRR(i, 5) = tempBook.Sheets("Main").Range("B2").Value 'ชั้น
                        aRR(i, 6) = rFind.Value 'คะแนน
                        aRR(i, 7) = rFind.Offset(0, -5).Value 'เลขที่
                        i = i + 1
                    End If
                Next rFind
            End With
            
            thsBook.Sheets("min").Range("a" & j).Resize(iCount, 7).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("ได้รับข้อมูลจาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

แต่ถ้า Sheet นั้นถูกล๊อค หล่ะครับ เราต้องปรับอย่างไรครับ
รหัสที่ Lock ชีทคือ 2564 ครับอาจารย์

[snasui]

ก็ต้อง Unprotect เสียก่อน ตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

'Other code
With tempBook.Sheets("เกรดเฉลี่ย")
  '  .Range("g7:g1000").SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
    .Unprotect Password:="2564"
    .Range("i7:i1000").Value = .Range("g7:g1000").Value
    .Range("i6").Value = "Grade"
'Other code