VBA ดึงคะแนนข้ามไฟล์มาแสดงตามชื่อรายวิชา

[aueijung]

อาจารย์ครับ จะแก้ปัญหาอย่างไรครับ การแสดงผลการดึงผิดพลาดไปครับ โดยที่ VBA ดึง(คะแนน, คุณลักษณะฯ, อ่าน คิด วิเคราะห์และเขียนสือความ) แต่ละไฟล์มาแสดงคลาดเคลื่อนไปครับ

Code: Select all

Sub P11_Click()
Dim directory As String, fileName As String
    Dim sheet As Worksheet, j As Integer
    Dim tempBook As Workbook, thsBook As Workbook
    Application.ScreenUpdating = False
    'directory = "D:\ปพ.5\ปีการศึกษา2557\ประถม\เทอม1-2\ป.1-1\"
    directory = Sheets("ป.1").Range("c1").Value
    fileName = Dir(directory & "*.xl??")
    Set thsBook = ThisWorkbook
    j = 5 'บรรทัดที่ 5 คอลัมภ์ที่ 1 ชื่อไฟล์ที่นำไปแสดง
    Do While fileName <> ""
        Set tempBook = Workbooks.Open(directory & fileName)
        thsBook.Sheets("ป.1").Cells(j, 1) = tempBook.Name
        thsBook.Worksheets("ป.1").Cells(j, 5).Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("k19").Value

      j = j + 1
        tempBook.Close False
        fileName = Dir()
    Loop
       
    Application.ScreenUpdating = True
    'MsgBox ("รับข้อมูล...จาก Directory " & Sheets("ปก").Range("c1").Value & " เรียบร้อยแล้วครับ")
End Sub

[snasui]

ช่วยอธิบายว่าเอาชีทไหน เซลล์ไหนของไฟล์ต้นทางมาวางในไฟล์ปลายทาง โดยมีเงื่อนไขอะไรบ้าง ฯลฯ ครับ

[aueijung]

ดึงข้อมูลจากชีท ปก ของแต่ละไฟล์ที่มีอยู่ใน directory D:\ปพ.5\ปีการศึกษา2557\ประถม\เทอม1-2\ป.1-1\ มาแสดงที่ไฟล์ rtaw-pm-test.xlsm ชีท ป.1 ตามสีเหลืองที่มาคไว้ด้วยเซลสีเหลืองครับ (คัดลอกข้อมูลในแต่ละไฟล์มาวางตามชื่อรายวิชา เกรด คุณลักษณะอันพึงประสงค์ และการอ่าน คิด วิเคราะห์ และเขียนสื่อความ)

[snasui]

กรณีนี้ให้อธิบายโดยชี้ถึงระดับเซลล์ ระบุตำแหน่งเซลล์เลย อย่าระบุค่าที่อยู่ในเซลล์ เพราะจะทำให้เสียเวลาในการค้นหาค่าที่อธิบายมาครับ

[aueijung]

ระดับผลการเรียน
ชีท ปก เซลล์ F14:P14 ดึงมาวางที่ชีท ป.1-1 เซลล์ D5:N5

คุณลักษณะอันพึงประสงค์
ชีท ปก เซลล์ C19:I19 ดึงมาวางที่ชีท ป.1-1 เซลล์ Q5:W5

การอ่าน คิดวิเคราะห์ และเขียนสื่อความ
ชีท ปก เซลล์ L19:R19 ดึงมาวางที่ชีท ป.1-1 เซลล์ Z5:AF5

ทุกๆไฟล์ที่มีในโฟลเด้อ ป.1-1 ก็ปฏิบัติเหมือนกันตามลำดับครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    With thsBook.Sheets("».1")
        .Cells(j, "a") = tempBook.Name
        .Cells(j, "d").Resize(1, 12).Value = _
            tempBook.Sheets("»¡").Range("f14:q14").Value
        .Cells(j, "q").Resize(1, 8).Value = _
            tempBook.Sheets("»¡").Range("c19:j19").Value
        .Cells(j, "z").Resize(1, 8).Value = _
            tempBook.Sheets("»¡").Range("l19:s19").Value
    End With
    j = j + 1
    tempBook.Close False
    fileName = Dir()
Loop

[aueijung]

อาจารย์ครับ ปรับใหม่เป็น
ระดับผลการเรียน
ชีท ปก เซลล์ F14:P14 ดึงมาวางที่ชีท ป.1-1 เซลล์ D5:M5

คุณลักษณะอันพึงประสงค์
ชีท ปก เซลล์ C19:I19 ดึงมาวางที่ชีท ป.1-1 เซลล์ O5:R5

การอ่าน คิดวิเคราะห์ และเขียนสื่อความ
ชีท ปก เซลล์ L19:R19 ดึงมาวางที่ชีท ป.1-1 เซลล์ T5:W5

อาจารย์ครับ เราสามารถปรับให้ชื่อไฟล์ที่แสดงที่ ชีท ป.1-1 เซลล์ A5 ให้ตรงกับรหัสวิชา 6 ตัว ที่เซลล์ B5 คือให้ชื่อไฟล์ตรงกัน เช่น
เซลล์ A5 ชื่อไฟล์ ค11101-1.xlsm ตรงกับค่ารหัสวิชา เซลล์ B5 ค11101 สามารถทำได้หรือไม่ครับ

Code: Select all

Sub P11_Click()
Dim directory As String, fileName As String
    Dim sheet As Worksheet, j As Integer
    Dim tempBook As Workbook, thsBook As Workbook
    Application.ScreenUpdating = False
    'directory = "D:\ปพ.5\ปีการศึกษา2557\ประถม\เทอม1-2\ป.1-1\"
    directory = Sheets("ป.1-1").Range("c1").Value
    fileName = Dir(directory & "*.xl??")
    Set thsBook = ThisWorkbook
    j = 5 'บรรทัดที่ 5 คอลัมภ์ที่ 1 ชื่อไฟล์ที่นำไปแสดง
    
    Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    With thsBook.Sheets("ป.1-1")
        .Cells(j, "a") = tempBook.Name
        .Cells(j, "d").Resize(1, 12).Value = _
            tempBook.Sheets("ปก").Range("f14:o14").Value
        .Cells(j, "o").Resize(1, 4).Value = _
            tempBook.Sheets("ปก").Range("c19:f19").Value
        .Cells(j, "t").Resize(1, 4).Value = _
            tempBook.Sheets("ปก").Range("l19:o19").Value
    End With
    j = j + 1
    tempBook.Close False
    fileName = Dir()
Loop
       
    Application.ScreenUpdating = True
    'MsgBox ("รับข้อมูล...จาก Directory " & Sheets("ปก").Range("c1").Value & " เรียบร้อยแล้วครับ")
End Sub

[aueijung]

ทำได้แล้วครับ แต่จะทำอย่างไรครับ จะให้ชื่อไฟล์ที่อยู่เซลล์ A5 ชีท ป.1-1 ตรงกับรหัสวิชาเซลล์ B5 ชีท ป.1-1 ครับอาจารย์

Code: Select all

Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    With thsBook.Sheets("ป.1-1")
        .Cells(j, "a") = tempBook.Name
        .Cells(j, "d").Resize(1, 8).Value = _
            tempBook.Sheets("ปก").Range("f14:m14").Value
        .Cells(j, "l").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("n14:o14").Value
        .Cells(j, "m").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("p14:q14").Value
            
         .Cells(j, "o").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("c14:e14").Value
            
        .Cells(j, "q").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("c19:d19").Value
        .Cells(j, "r").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("e19:f19").Value
        .Cells(j, "s").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("g19:h19").Value
         .Cells(j, "t").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("i19:j19").Value
            
        .Cells(j, "v").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("l19:m19").Value
        .Cells(j, "w").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("n19:o19").Value
        .Cells(j, "x").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("p19:q19").Value
         .Cells(j, "y").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("r19:s19").Value
    End With
    j = j + 1
    tempBook.Close False
    fileName = Dir()
Loop

[snasui]

จะให้ตรงกันก็ต้องวางที่ A6 ครับ ไม่ใช่ไปวางที่ A5

และหากวางที่ A6 ไม่ได้ก็ให้อธิบายมาว่าเหตุใดจึงวางไม่ได้ หรือแจ้งมาโดยละเอียดว่ามีเงื่อนไขการพิจารณาอย่างไรว่าให้วาตรงนั้นวางตรงนี้ จึงจะตอบได้ครับ

[aueijung]

ใช่ๆ ครับอาจารย์
ถ้าชื่อไฟล์มีอัขระ ค11101-1.xlsm ตรงกันกับรหัสวิชา ค11101 ก็ต้องวางที่เซลล์ A6
ถ้าชื่อไฟล์มีอัขระ ง11101-1.xlsm ตรงกันกับรหัสวิชา ง11101 ก็ต้องวางที่เซลล์ A12
ถ้าชื่อไฟล์มีอัขระ จ11101-1.xlsm ตรงกันกับรหัสวิชา จ11101 ก็ต้องวางที่เซลล์ A14
ถ้าชื่อไฟล์มีอัขระ ท11101-1.xlsm ตรงกันกับรหัสวิชา ท11101 ก็ต้องวางที่เซลล์ A5
ฯลฯ
จนครบทั้งหมดในโฟลเด้อนั้นๆ ถ้าไม่ตรงกันก็ไม่ต้องวาง จนกว่าจะเจอรหัสวิชาที่ตรงกันจึงจะวางข้อมูล หรือออกจากการวางค่าเมื่อไม่มีไฟล์ในโฟลเด้อ D:\ปพ.5\ปีการศึกษา2557\ประถม\เทอม1-2\ป.1-1\ ครับอาจารย์

[snasui]

ประกาศตัวแปรเพิ่มเป็น

Code: Select all

Dim bookStr As String, rw As Integer

จากนั้นปรับการ Loop เป็นด้านล่างครับ

Code: Select all

Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    bookStr = VBA.Left(tempBook.Name, 6)
    On Error Resume Next
    With thsBook.Sheets("ป.1-1")
        rw = Application.Match(bookStr, .Range("b5:b10000"), 0) - 1
        If Err <> 0 Then
            MsgBox "File " & tempBook.Name & " not found in column B."
            Err = 0
        Else
            .Cells(j + rw, "a") = tempBook.Name
            .Cells(j + rw, "d").Resize(1, 8).Value = _
                tempBook.Sheets("ปก").Range("f14:m14").Value
            .Cells(j + rw, "l").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("n14:o14").Value
            .Cells(j + rw, "m").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("p14:q14").Value
            
            .Cells(j + rw, "o").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("c14:e14").Value
            
            .Cells(j + rw, "q").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("c19:d19").Value
            .Cells(j + rw, "r").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("e19:f19").Value
            .Cells(j + rw, "s").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("g19:h19").Value
            .Cells(j + rw, "t").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("i19:j19").Value
            
            .Cells(j + rw, "v").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("l19:m19").Value
            .Cells(j + rw, "w").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("n19:o19").Value
            .Cells(j + rw, "x").Resize(1, 1).Value = _
            tempBook.Sheets("ปก").Range("p19:q19").Value
            .Cells(j + rw, "y").Resize(1, 1).Value = _
                tempBook.Sheets("ปก").Range("r19:s19").Value
        End If
    End With
    'j = j + 1
    tempBook.Close False
    fileName = Dir()
Loop

[aueijung]

ได้แล้วครับอาจารย์ สุดยอดเลยครับ ขอบพระคุณมากๆครับอาจารย์ ผมอยากทำ Excel ให้เก่งๆ เหมือนอาจารย์จังเลยครับ ต้องทำหรือเตรียมตัวอย่างไรบ้างครับ

[snasui]

ลองอ่านที่ผมเคยเขียนถึงตัวเองไว้ที่นี่ครับ http://www.snasui.com/viewtopic.php?t=2014

ปัจจุบันหากทำไฟล์ไว้แจกบางไฟล์จะมีการป้องกันเอาไว้บ้างเพื่อไม่ให้ผู้ไม่หวังดีนำไปหาประโยชน์เชิงเศรษฐกิจ