VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

aueijung · #1

เรียนอาจารย์ที่เคารพครับ
ถ้าเราต้องการให้แสดงคะแนนมากที่สุด 1 คนของรายวิชานั้น แต่ถ้าคะแนนสูงสุดเท่ากัน ก็ให้แสดงคนที่มีคะแนนสูงสุดเท่ากันในแต่ละวิชา โดยแสดงชื่อวิชา ชื่อ-นามสกุล ระดับชั้น ห้อง และคะแนนสูงสุด ต่อกันลงมาเป็นแถวถัดไป ที่ชีท MaxM4 เซลล์ a3:f10000
ผลที่ได้ออกมาคือ แสดงเฉพาะคนเดียว และคะแนนก็ยังไม่ได้มีค่ามากที่สุด จากโค๊ดด้านล่างนี้ต้องปรับตรงตำแหน่งใดบ้างครับ

Code: Select all

Sub MaxM4_Click()
    Dim directory As String, fileName As String
    Dim sheet As Worksheet, j, i, r, max, Min As Integer
    Dim tempBook As Workbook, thsBook As Workbook
    Dim bookStr As String, rw As Integer
    Application.ScreenUpdating = False
    directory = Sheets("MaxM4").Range("o2").Value
    fileName = Dir(directory & "*.xl??")
    Set thsBook = ThisWorkbook
    j = 3 
    
Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    bookStr = VBA.Left(tempBook.Name, 6)
    On Error Resume Next
    With thsBook.Sheets("MaxM4")
        rw = Application.Match(bookStr, .Range("r2:r10000"), 0) - 1
        If Err <> 0 Then
            MsgBox "File " & tempBook.Name & " ไม่พบไฟล์ใน column R."
            Err = 0
        Else
           .Cells(j, "a") = tempBook.Name
‘ให้แสดงคะแนนมากที่สุด  1 คนของรายวิชานั้น  แต่ถ้าคะแนนสูงสุดเท่ากัน  ก็ให้แสดงคนที่มีคะแนนสูงสุดเท่ากันในแต่ละวิชา  โดยแสดงชื่อวิชา  ชื่อ-นามสกุล  ระดับชั้น  ห้อง  และคะแนนสูงสุด ต่อกันลงมาเป็นแถวถัดไป  ที่ชีท MaxM4 เซลล์ a3:f10000
'i = 7
r = 7
'Min = 0
max = 100
Do Until tempBook.Sheets("รายงาน1").Range("i" & r) = ""
If tempBook.Sheets("รายงาน1").Range("i" & r) <= max Then .Cells(j, "f").Resize(1, 1).Value = _
                 tempBook.Sheets("รายงาน1").Range("i" & r).Value
             .Cells(j, "c").Resize(1, 1).Value = _
                 tempBook.Sheets("รายงาน1").Range("d" & r).Value
             .Cells(j, "d").Resize(1, 1).Value = _
                 tempBook.Sheets("รายงาน1").Range("e" & r).Value
            .Cells(j, "b").Resize(1, 1).Value = _
                 tempBook.Sheets("Home").Range("c12").Value
             .Cells(j, "g").Resize(1, 1).Value = _
                  tempBook.Sheets("Home").Range("c9").Value
             .Cells(j, "h").Resize(1, 1).Value = _
                  tempBook.Sheets("Home").Range("e9").Value
                  
r = r + 1
Loop

        End If
    End With
    j = j + 1
    tempBook.Close False
    fileName = Dir()
Loop
       
    Application.ScreenUpdating = True
    MsgBox ("รับไฟล์จาก Directory " & Sheets("MaxM4").Range("o2").Value & " เรียบร้อยแล้วค่ะ")

End Sub

ถ้าต้องการผลลัพธ์ให้ได้ตามภาพนี้ ควรปรับตรงตำแหน่งใดครับ

DhitiBank · #2

ลองปรับโค้ดแบบนี้ครับ

Code: Select all

Sub MaxM4_Click()
    Dim directory As String, fileName As String, bookStr As String
    Dim j As Integer, iMax As Integer, 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 คอลัมน์ที่  1
    thsBook.Sheets("maxm4").Range("a3:h1000").ClearContents
    
    For Each r In thsBook.Sheets("maxm4").Range("o2:o4")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 6)
            With thsBook.Sheets("maxm4")
                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(2)
                iMax = WorksheetFunction.max(.Range("i7:i1000"))
                iCount = Application.CountIf(.Range("i7:i1000"), iMax)
                ReDim aRR(1 To iCount, 1 To 8)
                Set rFind = .Range("i6")
                For i = 1 To iCount
                    Set rFind = .Columns("i:i").Find(what:=iMax, after:=rFind, _
                        LookIn:=xlValues, searchorder:=xlByRows)
                    aRR(i, 1) = tempBook.Name
                    aRR(i, 2) = tempBook.Sheets(1).Range("c12").Value
                    aRR(i, 3) = rFind.Offset(0, -5).Value
                    aRR(i, 4) = rFind.Offset(0, -4).Value
                    aRR(i, 5) = "ม." & VBA.Right(tempBook.Sheets(1).Range("c9").Value, 1) _
                        & "/" & tempBook.Sheets(1).Range("e9").Value
                    aRR(i, 6) = rFind.Value
                    aRR(i, 7) = tempBook.Sheets(1).Range("c9").Value
                    aRR(i, 8) = tempBook.Sheets(1).Range("e9").Value
                Next i
            End With
            
            thsBook.Sheets("maxm4").Range("a" & j).Resize(iCount, 8).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("รับไฟล์จาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

เห็นว่ามีการตั้งกระทู้ถามคำถามเดียวกัน 2 กระทู้ กดผิดหรือเปล่าครับ

aueijung · #3

ขอบพระคุณมากๆ ครับ ปรับแต่ง ใช้งานได้อย่างดีเยี่ยมครับ

aueijung · #4

จากโค๊ดที่อาจารย์ให้มา ใช้ได้ดีมากครับ แต่จะสอบถามอาจารย์ อีกประการครับ
หากต้องการให้ข้อมูลเรียงลำดับตามชื่อไฟล์ ในคอลัมน์ R2:R10000 เช่น รหัส ท31102 วิชาภาษาไทย มีเรียนทั้ง 3 ห้อง ในชั้น ม.4/1,ม.4/2,ม.4/3 ก็ให้แสดงข้อมูลวิชาภาษาไทย ก่อนของทั้ง 3 ห้อง แล้วค่อยเว้นบรรทัด 1 บรรทัด ไปแสดงรหัส ค31102 วิชาคณิตศาสตร์ คนที่เรียนวิชาคณิตศาสตร์ มีเรียนทั้ง 3 ห้อง ในชั้น ม.4/1,ม.4/2,ม.4/3 ก็ให้แสดงข้อมูลวิชาคณิตศาสตร์ แต่มีบางวิชาที่ทั้ง 3 ห้องเรียนไม่เหมือนกัน ก็ให้แสดงของห้องเดียว หรือ 2 ห้อง เฉพาะที่นักเรียนห้องนั้นๆ มีเรียน เช่นเรียน
รหัส จ31202 วิชาภาษาจีน 2 เป็นห้อง ม.4/3 เท่านั้นที่เรียนรหัสนี้ ก็ให้แสดงรหัสนี้เพียงห้องเดียว ส่วนห้อง ม.4/1,ม.4/2 เรียนวิชาภาษาจีน 2 แต่รหัสวิชาไม่เหมือนกัน ก็ให้แยกออกมาเป็นข้อมูลของห้อง ม.4/1,ม.4/2

ไม่รู้ว่าผมอธิบายได้ชัดเจนบ้างหรือเปล่า
สรุปคือ เรียงข้อมูลตามรหัสวิชา ห้องใดเรียนรหัสใด ก็ให้แสดงรหัสนั้น หากใครเรียนรหัสเดียวกัน ก็ให้แสดงข้อมูลของคนที่เรียนรหัสเดียวกัน แล้วค่อยเว้น 1 บรรทัด ไปค้นหาข้อมูลลำดับต่อไป (ยึดห้อง 1,2,3 เรียงตามลำดับห้องในแต่รหัสวิชา)

Code: Select all

Sub MaxM4_Click()
    Dim directory As String, fileName As String, bookStr As String
    Dim j As Integer, iMax As Integer, 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 คอลัมน์ที่  1
    thsBook.Sheets("maxm4").Range("a3:h1000").ClearContents
    
    For Each r In thsBook.Sheets("maxm4").Range("o2:o4")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 6)
            With thsBook.Sheets("maxm4")
                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(2)
                iMax = WorksheetFunction.max(.Range("i7:i1000"))
                iCount = Application.CountIf(.Range("i7:i1000"), iMax)
                ReDim aRR(1 To iCount, 1 To 8)
                Set rFind = .Range("i6")
                For i = 1 To iCount
                    Set rFind = .Columns("i:i").Find(what:=iMax, after:=rFind, _
                        LookIn:=xlValues, searchorder:=xlByRows)
                    aRR(i, 1) = tempBook.Name
                    aRR(i, 2) = tempBook.Sheets(1).Range("c12").Value
                    aRR(i, 3) = rFind.Offset(0, -5).Value
                    aRR(i, 4) = rFind.Offset(0, -4).Value
                    aRR(i, 5) = "ม." & VBA.Right(tempBook.Sheets(1).Range("c9").Value, 1) _
                        & "/" & tempBook.Sheets(1).Range("e9").Value
                    aRR(i, 6) = rFind.Value
                    aRR(i, 7) = tempBook.Sheets(1).Range("c9").Value
                    aRR(i, 8) = tempBook.Sheets(1).Range("e9").Value
                Next i
            End With
            
            thsBook.Sheets("maxm4").Range("a" & j).Resize(iCount, 8).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("รับไฟล์จาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

จะต้องปรับอย่างไรครับ เพื่อให้ได้ผลลัพธ์ดังภาพนี้

DhitiBank · #5

ผมเป็นเพื่อนสมาชิกเหมือนกันครับ ไม่ใช่อาจารย์ ผมเข้ามาเรียนแล้วก็หาการบ้านทำเป็นระยะครับ
สำหรับสิ่งที่ต้องการเพิ่มเติม ลองปรับโค้ดมาเองดูก่อนครับ หากติดแล้วค่อยถามกันต่อครับ

aueijung · #6

ขอบคุณมากๆ ครับที่ช่วยเหลือกระผม ถึงอย่างไรก็อยากจะขอเรียกว่าอาจารย์อีกท่านนะครับ อ.DhitiBank ไม่ว่ากันนะครับ

Snasui Excel Forum

File Anatomy Add-in: แก้ปัญหาไฟล์ Excel ช้า แฮงก์ และไม่เสถียร อย่างมืออาชีพ

VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

Re: VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

Re: VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

Re: VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

Re: VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด

Re: VBA แสดงค่ามากที่สุด ตามเงื่อนไขที่กำหนด