Snasui Excel Forum

Code: Select all

Sub MaxM_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
    thsBook.Sheets("maxm").Range("a3:g1000").ClearContents
    
    For Each r In thsBook.Sheets("maxm").Range("o2:o7")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 10)
            With thsBook.Sheets("maxm")
                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("เกรดเฉลี่ย")
                iMax = (WorksheetFunction.Max(.Range("g7:g1000")))
                iCount = Application.CountIf(.Range("g7:g1000"), iMax)
                ReDim aRR(1 To iCount, 1 To 6)
                Set rFind = .Range("g7")   'i6
                For i = 1 To iCount
                    Set rFind = .Columns("g:g").Find(what:=iMax, after:=rFind, _
                        LookIn:=xlValues, searchorder:=xlByRows)
                    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 'เกรดเฉลี่ย
                Next i
            End With
            
            thsBook.Sheets("maxm").Range("a" & j).Resize(iCount, 6).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("ได้รับไฟล์จาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub MaxM_Click()
    Dim directory As String, fileName As String, bookStr As String
    Dim j As Integer, iMax 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("maxm").Range("a3:g1000").ClearContents
    
    For Each r In thsBook.Sheets("maxm").Range("o2:o7")
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        
        Do Until Len(fileName) = 0 'ถ้าพบไฟล์ *.xl*
            bookStr = VBA.Left(fileName, 10)
            With thsBook.Sheets("maxm")
                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
                iMax = Application.WorksheetFunction.Large(.Range("i7:i1000"), 3)
                iCount = Application.CountIf(.Range("g7:g1000"), ">=" & iMax)
                ReDim aRR(0 To iCount, 1 To 6)
                i = 0
                For Each rFind In .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
                    If rFind.Value >= iMax 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 'เกรดเฉลี่ย
                        i = i + 1
                    End If
                Next rFind
            End With
            
            thsBook.Sheets("maxm").Range("a" & j).Resize(iCount, 6).Value = aRR
            j = j + iCount
            tempBook.Close False
            fileName = Dir()
        Loop
        MsgBox ("ได้รับไฟล์จาก Directory " & r.Value & " เรียบร้อยแล้วค่ะ")
    Next r
    Application.ScreenUpdating = True
End Sub

Code: Select all

SpecialCells(xlCellTypeConstants, 16