นโยบายการจัดการความรู้ มหาวิทยาลัยสงขลานครินทร์ 1.ให้ใช้เครื่องมือการจัดการความรู้ผลักดัน คุณภาพคน และกระบวนทำงาน 2.ส่งเสริมการแลกเปลี่ยนประสบการณ์การทำงาน จากหน้างาน 3.ส่งเสริมให้มีเวทีเรียนรู้ร่วมกัน
อ่าน: 7889
ความเห็น: 0

วิธีเขียน VBA จัดการข้อมูล MS Excel 2,200 ไฟล์ [C]

วิธีเขียน VBA จัดการข้อมูล MS Excel 2,200 ไฟล์

ปัญหา
ใน Folder "source" หนึ่ง มีไฟล์ Excel จำนวน 2,200 ไฟล์ เก็บข้อมูล ซึ่งมีลักษณะดังนี้
- ชื่อไฟล์ มีรูปแบบ xxxxx-zz.xls ซึ่งต้อเอาชื่อมาใช้ในการจัดการข้อมูลต่อไป
 และแต่ละ Sheet ป้องกันการแก้ไข ต้องใส่ Password ก่อนจึงจะแก้ไขได้


- บรรทัดที่ 1-6  แรก จะมีคำอธิบายข้อมูล  และ มีการ merge cell เอาไว้
   และบรรทัดที่ 6 จะมีข้อมูลระบุภาคการศึกษา ที่ต้องเอาข้อมูลขึ้นมาทำงานต่อไป
 มีรูปแบบ "ภาคการศักษา  t/yyyy"
- บรรทัดที่ 7 จะเป็นหัวตาราง
- ตั้งแต่บรรทัดที่ 8 เป็นต้นไป จะเป็นข้อมูล ข้อมูลอยู่ใน A-E
 จำนวนบรรทัดข้อมูล ไม่แน่นอน
- เมื่อหมดข้อมูล มี Summary เป็น Merge Cell คำนวนว่ามีใครได้ A,B,C... กีคน
 ต่อกัน 2 บรรทัด
- ยิ่งไปกว่านั้น มีรูปแบบนี้ ซ้ำไปอีก ไม่แน่นอน

หากคำนวนง่าย ใช้เวลาแก้ไขไฟล์ละ 1 นาที จะใช้เวลาทั้งหมด
= 2,200/60 = 36.66 ชั่วโมง

โจทย์
- ลบ "คำอธิบาย", "Summary"และหัวตาราง ทิ้ง
- เอาข้อมูล xxxxx ใส่ คอลัมน์ F
- เอาข้อมูล zz ใส่ คอลัมน์ G
- เอาข้อมูล t ใส่ คอลัมน์ H
- เอาข้อมูล yyyy ใส่ คอลัมน์ I
- เมื่อใส่ข้อมูลแต่ละบรรทัดแล้ว ให้เก็บข้อมูลลง Text File (รวมกันทั้ง 2,200 ไฟล์) เพื่อนำไปใส่ฐานข้อมูลต่อไป
- เมื่อจัดการข้อมูลใสไฟล์นี้เสร็จแล้วจนเหลือแต่ ข้อมูล
 ให้ Save ไปไว้ใน Folder "result" และไฟล์ต้นฉบับต้องไม่เปลี่ยนแปลง

แนวคิด
1. ลิสต์ไฟล์ใน folder "source" ขึ้นมา
2. วนลูปชื่อไฟล์ แต่ละไฟล์ ตัดเอา xxxxx-yy.txt โดยแยกด้วย "." ก่อน แล้ว ค่อยมาแยกด้วย "-" อีกครั้งเพื่อเอาข้อมูล
 ได้ xxxxx และ yy
3. เปิดไฟล์ขึ้นมา แล้ว Unprotect ข้อมูลใน Sheet
4. อันดับแรก ต้องเอาข้อมูลปีการศึกษาขึ้นมาก่อน โดยตรงไปที่ A6 เพื่อเอาข้อมูลขึ้นมา
  ตัดข้อความตั้งแต่ตัวอักษรที่ 13 ("ภาคการศึกษา" มีความยาว 13 ตัวอักษร)  แล้ว Trim (ตัดช่องว่างทั้งหน้าหลัง)
 จากนั้น แยกด้วย "/" จะได้ t และ yyyy ออกมา
5. Unmerge Column A:E
6. วนลูปทีละบรรทัดจนเจอบรรทัดที่ Column A เป็นค่าว่าง ให้หยุด
 6.1 ถ้าเจอ B เป็นค่าว่าง --> ลบทั้งบรรทัด (ลบ "คำอธิบาย", "Summary" )
 6.2 ถ้าเจอ A มีค่าเป็น "รหัสนักศึกษา" --> ลบทั้งบรรทัด (ลบ หัวตาราง)
 6.3
   - เอาข้อมูล xxxxx ใส่ คอลัมน์ F
   - เอาข้อมูล zz ใส่ คอลัมน์ G
   - เอาข้อมูล t ใส่ คอลัมน์ H
   - เอาข้อมูล yyyy ใส่ คอลัมน์ I
 6.4 เอาค่าจาก Column A ถึง I ทีละค่า คั่นด้วย "," แล้วเขียนต่อท้ายไฟล์
 วนลูปทำต่อไปจนจบไฟล์
7. Save As ไว้ใน Folder "result" ชื่อไฟล์เดิม
   และ ปิดไฟล์ดั้งเดิม โดยไม่เปลี่ยนแปลงใดๆ
วนลูปจนครบทุกไฟล์

วิธีการทำงานจริง

สร้าง Excel ขึ้นมาใหม่ แล้วกดปุ่ม Alt-F11 เพื่อเข้าหน้าจอ VBA
แล้วเขียน code ดังนี้ เมื่อต้องการทำงาน ให้กดปุ่ม F5 เพื่อส่งให้ทำงาน

ใช้เวลาให้ Script ทำงานเพียง 45 นาที (จาก 36 ชั่วโมง)

Sub doit() คือส่วนที่เขียนตามกระบวนการข้างต้น
Function GetFileList() หามาจาก Internet ต้นฉบับอยู่ที่
http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/


Sub doit()
    Dim fls() As Variant
    Dim OWB As Workbook
    Dim source_path
    Dim result_path
    Dim subj_key
    Dim section
    Dim edu_term
    Dim edu_year
    
    source_path = "C:\Users\kanakorn\Desktop\regist\source\"
    result_path = "C:\Users\kanakorn\Desktop\regist\result\"
    fls = GetFileList(source_path & "*.xls")
    
    On Error Resume Next
    
    ' Open Result Text File
    Open "C:\Users\kanakorn\Desktop\regist\result\result.txt" For Append As #1
    
    For Each f In fls
        Dim x1
        Dim x2
        Dim x3
                
    ' Get xxxxx-zz
        x1 = Split(f, ".")
        x2 = Split(x1(0), "-")        
        subj_key = x2(0)
        section = x2(1)
        
        Set OWB = Workbooks.Open(source_path & f)
        ' Unprotect Worksheet
        OWB.Worksheets(1).Unprotect Password:="password"
    ' Get t/yyyy
        x3 = OWB.Worksheets(1).Range("A6")
        x4 = Split(Trim(Mid(x3, 13)), "/")
        edu_term = x4(0)
        edu_year = x4(1)
        
        With OWB.Worksheets(1)
        ' Unmerge Column A:E
            .Range("A:E").UnMerge
            i = 1
        
            ' Loop Until Column A is Blank
            Do While .Range("A" & i) <> ""            
                If .Range("B" & i) = "" Then
                    .Rows(i).EntireRow.Delete                
                Else
                    If .Range("A" & i) = "รหัสนักศึกษา" Then
                        .Rows(i).EntireRow.Delete
                    Else                    
                    .Range("F" & i) = "'" & subj_key
                    .Range("G" & i) = "'" & section
                    .Range("H" & i) = "'" & edu_term
                    .Range("I" & i) = "'" & edu_year  
             
             ' Print A:I to text result text file                
                    Print #1, .Range("A" & i) & "," & .Range("B" & i) & "," _
                        & .Range("C" & i) & "," & .Range("D" & i) & "," _
                        & .Range("E" & i) & "," & .Range("F" & i) & "," _
                        & .Range("G" & i) & "," & .Range("H" & i) & "," _
                        & .Range("I" & i)                    
                    i = i + 1                    
                    End If
                End If             
            Loop ' End loop While                    
        End With
    
    ' Save As to Folder "Result"
        OWB.SaveCopyAs result_path & f
     ' Close Without Changes
        OWB.Close SaveChanges:=False                
    Next
    ' Close Text File
    Close #1
End Sub

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
        
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

Sections: Miscellaneous
Tag: excel  vba
License: สงวนสิทธิ์ทุกประการ Copyright
created: 07 April 2010 09:43 Modified: 07 April 2010 09:52 [ Report Abuse ]
ดอกไม้
People Who Like This
 
Facebook
Twitter
Google

Other Posts By This Blogger

ความเห็น

ไม่มีความเห็น
คุณต้องทำการเข้าระบบก่อนแสดงความเห็น