EXCEL TOOLS
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
[code]
และปิดด้วย [/code]
ตัวอย่างเช่น [code]dim r as range[/code]
เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)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