Snasui Excel Forum

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

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

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