การแยกข้อมูลออกจากฐานป็นเดือน

[yodpao.b]

Code: Select all

Sub MacroAdvancedFilter()   'code นี้อยู่ในโมดูล 8
    Workbooks.Add
    Range("A5").Select  'กรองข้อมุล
    Workbooks("OT_New.xls").Sheets("ฐานข้อมูลล่วงเวลา").Range("A6:AC65536"). _
        AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Workbooks("OT_New.xls") _
        .Sheets("ฐานข้อมูลล่วงเวลา").Range("X2:X3"), CopyToRange:=Range("A5"), _
        Unique:=False

    Windows("OT_New.xls").Activate      'copy
    Rows("4:6").Select
    Selection.Copy
    Application.WindowState = xlMinimized
    [color=#BF4080]Windows("Book6").Activate[/color]
    Range("A3").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
End Sub

อาจาร์ยครับ Code ด้านบน ผมใช้แมโครทำขึ้นมา คือการกรองข้อมูลขั้นสูงแล้วนำมาไว้ใน Workbooks ใหม่
ต่อจากนั้นเป็นการ Copy จาก Workbooks("OT_New.xls").Sheets("ฐานข้อมูลล่วงเวลา") บรรทัดที่ 4-6
มาไว้ใน สมุดงานใหม่
แต่โปรแกรม eeror ตรงที่ Code "Windows("Book6").Activate"
สาเหตุคงจะเป็นตรงชื่อสมุดงานครับ จะแก้ไขอย่างไรดี
(เชลที่ใช้เลือกเดือนอยู่ที่ x2 , x3) ในSheets("ฐานข้อมูลล่วงเวลา")

[snasui]

แต่โปรแกรม eeror ตรงที่ Code "Windows("Book6").Activate"
สาเหตุคงจะเป็นตรงชื่อสมุดงานครับ จะแก้ไขอย่างไรดี

ลองเปลี่ยนเป็น Windows("Book6.xls").Activate หรือ Windows("Book6.xlsx").Activate (ขึ้นอยู่กับว่าใช้ Excel Version ใด) ดูครับ

[yodpao.b]

เหมือนเดิมครับอาจาร์ย มันออกมาเฉพาะข้อมูล หัวข้อไม่ออก
เข้าใจว่าชื่อ book มันเปลี่ยนไปเรื่อย มันน่าจะใช้ลัษณะนามว่า
bookที่คุณใช้งานก่อนหน้านี้ ให้ทำการ copy
ขอบคุณครับ พรุ่งนี้พบกันใหม่

[snasui]

ลองดู Code ด้านล่างครับว่าทำงานได้หรือไม่

Code: Select all

Sub MacroAdvancedFilter()
    Set Newbook = Workbooks.Add
    Workbooks("OT_New.xls").Activate
    Sheets("ฐานข้อมูลล่วงเวลา").Range("A5").Select    '   การกรองข้อมูล
    Workbooks("OT_New.xls").Sheets("ฐานข้อมูลล่วงเวลา").Range("A6:AC65536"). _
        AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Workbooks("OT_New.xls") _
        .Sheets("ฐานข้อมูลล่วงเวลา").Range("X2:X3"), CopyToRange:=Range("A5"), _
        Unique:=False        
    Windows("OT_New.xls").Activate   '   การ copy
    Rows("4:6").Select
    Selection.Copy
    Application.WindowState = xlMinimized
    Newbook.Activate
    Range("A3").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
End Sub

[yodpao.b]

เรียบร้อยแล้วครับอาจาร์ย
ต้องเอาบรรทัดนี้ออกด้วยครับถึงไม่ Error
"Workbooks("OT_New.xls").Activate"
เคยได้ยินอาจาร์ยเขียนว่า ให้ลอง รันที่ละสเตป หมายถึง สามารถสั่งให้รันที่ละบบรทัดได้หรือครับ

[snasui]

เคยได้ยินอาจาร์ยเขียนว่า ให้ลอง รันที่ละสเตป หมายถึง สามารถสั่งให้รันที่ละบบรทัดได้หรือครับ

ยินดีด้วยครับ สำหรับการ Run ทีละ Step ให้กดแป้น F8 ซ้ำ ๆ แล้วดูผลครับ จะติดตามได้ว่าติดที่บรรทัดใด จะได้แก้ได้ตรงจุดครับ

[yodpao.b]

ขอบคุณครับ

[yodpao.b]

Code: Select all

Sub MacroAdvancedFilter()
On Error Resume Next

    Set Newbook = Workbooks.Add
    Range("A5").Select  '¡Ãͧ¢éÍÁØÅ
    Workbooks("OT_New.xls").Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("A6:AC65536"). _
        AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Workbooks("OT_New.xls") _
        .Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("X2:X3"), CopyToRange:=Range("A5"), _
        Unique:=False
                
    If Range("A6") <> "" Then
                Windows("OT_New.xls").Activate   '   ¡ÒÃ copy
                Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Select
                Rows("4:6").Select
                Selection.Copy
                Application.WindowState = xlMinimized
                Newbook.Activate
                Range("A3").Select
                ActiveSheet.Paste
                Range("A1").Select
                Application.CutCopyMode = False
                
    Columns("A:AC").Select   '   ¨Ñ´¤ÇÒÁ¡ÇéÒ§àªÅ
    Columns("A:AC").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 18.86
    Columns("F:F").ColumnWidth = 14.57
    Columns("G:G").ColumnWidth = 11.86
    Columns("H:H").ColumnWidth = 17
    Columns("I:I").ColumnWidth = 18
    Range("A1").Select
                
                                    MsgBox "·èÒ¹·Ó¡Òà Export File à´×͹  " & Range("X6") & "  àÃÕºÂÃéÍÂáÅéÇ ¡ÃØ³Ò Save File ´éÇÂ", vbExclamation, "Export File"
                                    'ActiveWorkbook.SaveAs
                                    ActiveWindow.Close
                            
            Else
                MsgBox "à´×͹·Õè·èÒ¹àÅ×Í¡äÁèÁÕã¹°Ò¹¢éÍÁÙÅ", vbExclamation, "Export File"
                ActiveWindow.Close
            End If
            
End Sub

Code: Select all

            Else
                MsgBox "à´×͹·Õè·èÒ¹àÅ×Í¡äÁèÁÕã¹°Ò¹¢éÍÁÙÅ", vbExclamation, "Export File"
                ActiveWindow.Close
            End If

เมื่อ สั่ง ปิด New Book เครื่องจะถามว่าต้องการ Save ไหม
เป็นไปได้ไหมครับ ให้ไฟล์ปิดไปเลยโดยไม่ต้องถามอะไรและไม่ Save ด้วย (สิ่งที่เครื่องถามอยู่ในรูปด้านล่าง)

Untitled.gif

[snasui]

เมื่อ สั่ง ปิด New Book เครื่องจะถามว่าต้องการ Save ไหม
เป็นไปได้ไหมครับ ให้ไฟล์ปิดไปเลยโดยไม่ต้องถามอะไร

เป็นไปได้ครับ สามารถใช้ Code ตามด้านล่างครับ

Code: Select all

ActiveWindow.Close False

[yodpao.b]

Code: Select all

  MsgBox "·èÒ¹·Ó¡Òà Export File à´×͹  " & Range("X6") & "  àÃÕºÂÃéÍÂáÅéÇ ¡ÃØ³Ò Save File ´éÇÂ", vbExclamation, "Export File"
                                    ActiveWorkbook.SaveAs
                                    'ActiveWindow.Close

อาจาร์ยครับแล้วในกรณีที่ต้องการ Save และให้แสดงถึงขั้นตอนการ Save ครับ
รองใช้ Save As แล้ว มัน Save โดยไม่ถามอะไรเลย

[snasui]

อาจาร์ยครับแล้วในกรณีที่ต้องการ Save และให้แสดงถึงขั้นตอนการ Save ครับ

ลองตามด้านล่างครับ

Code: Select all

'Other code
fileSaveName = Application.GetSaveAsFilename( _
    fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
    MsgBox "Save as " & fileSaveName
End If 
'Other code

[yodpao.b]

เรียนอาจารย์ครับอยากให้อาจาร์ยช่วย Run Code นี้หน่อยครับ ไม่เข้าใจว่าทำไม่ excle ถึงอยู่เมนูบาร์ด้านล่าง มันไม่ยอมทำงานให้จบขั้นตอนครับ

Untitled3.gif

Code: Select all

Sub MacroAdvancedFilter()
On Error Resume Next

    Set Newbook = Workbooks.Add
    Range("A5").Select  '¡Ãͧ¢éÍÁØÅ
    Workbooks("OT_New.xls").Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("A6:AC65536"). _
        AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Workbooks("OT_New.xls") _
        .Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("X2:X3"), CopyToRange:=Range("A5"), _
        Unique:=False
                
    If Range("A6") <> "" Then
                                                            
                Windows("OT_New.xls").Activate   '   ¡ÒÃ copy
                Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Select
                Rows("4:6").Select
                Selection.Copy
                Application.WindowState = xlMinimized
                Newbook.Activate
                Range("A3").Select
                ActiveSheet.Paste
                Range("A1").Select
                Application.CutCopyMode = False
                
    Columns("A:AC").Select   '   ¨Ñ´¤ÇÒÁ¡ÇéÒ§àªÅ
    Columns("A:AC").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 18.86
    Columns("F:F").ColumnWidth = 14.57
    Columns("G:G").ColumnWidth = 11.86
    Columns("H:H").ColumnWidth = 17
    Columns("I:I").ColumnWidth = 18
    Range("A1").Select
    
                                          MsgBox "·èÒ¹·Ó¡Òà Export File à´×͹  " & Range("X6") & "  àÃÕºÂÃéÍÂáÅéÇ ¡ÃØ³Ò Save File ´éÇÂ", vbExclamation, "Export File"
                                         ActiveWindow.Close
                            
            Else
                MsgBox "à´×͹·Õè·èÒ¹àÅ×Í¡äÁèÁÕã¹°Ò¹¢éÍÁÙÅ", vbExclamation, "Export File"
                ActiveWindow.Close False
            End If
End Sub

ทั้งนี้ผมได้แนบไฟล์และวิธี RUn from6

Untitled1.gif

Untitled2.gif

Untitled3.gif

[yodpao.b]

แนบไฟล์

[snasui]

ก่อนที่จะถามในประเด็นต่อไป ควรจะตอบด้วยครับว่าที่ผมตอบไปคราวก่อนนั้นได้ผลหรือไม่อย่างไร หากไม่ได้ผลได้ใช้การแก้ไขด้วยวิธีใดไปแล้วหรือไม่

[yodpao.b]

Sub Macro1()
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
End Sub
จากหัวข้อที่แล้ว โคด้ที่อาจาร์ยให้มา ตรงตามที่ต้องการครับแต่ว่าเมื่อทดสอบดูมันไม่ Save ลง เครื่อง
ผมเลยใช้ โดดด้านล่างนี้ไปก่อน ได้ผลคล้ายกันแต่มันไม่แสดง MsgBox เท่านั้นเอง กะว่าจะลองไปทดสอบใหม่ในวันหยุด
ถ้าอาจาร์ยมีเวลารบกวนช่วยตอบคำถามข้อถัดมาด้วยครับ

[yodpao.b]

Sub Macro1()
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
End Sub
จากหัวข้อที่แล้ว โคด้ที่อาจาร์ยให้มา ตรงตามที่ต้องการครับแต่ว่าเมื่อทดสอบดูมันไม่ Save ลง เครื่อง
ผมเลยใช้ โดดด้านล่างนี้ไปก่อน ได้ผลคล้ายกันแต่มันไม่แสดง MsgBox เท่านั้นเอง กะว่าจะลองไปทดสอบใหม่ในวันหยุด
ถ้าอาจาร์ยมีเวลารบกวนช่วยตอบคำถามข้อถัดมาด้วยครับ

Code: Select all

ActiveWindow.Close

[snasui]

Sub Macro1()
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
End Sub
จากหัวข้อที่แล้ว โคด้ที่อาจาร์ยให้มา ตรงตามที่ต้องการครับแต่ว่าเมื่อทดสอบดูมันไม่ Save ลง เครื่อง
...

ลองทดสอบ Code ด้านล่างครับว่า Save ในตำแหน่งที่เลือกหรือไม่

Code: Select all

Sub Macro1()
Dim fileSaveName As String
fileSaveName = Application.GetSaveAsFilename( _
    fileFilter:="Excel Files (*.xls), *.xls")
ActiveWorkbook.SaveAs Filename:=fileSaveName
If fileSaveName <> "False" Then
    MsgBox "Save as " & fileSaveName
End If
End Sub

[yodpao.b]

Save แล้วครับอาจาร์ย ขอบคุณมากครับ อาจารย์ขอข้อถัดไปด้วยครับ

[snasui]

จากคำถามที่ว่าไม่จบขั้นตอน ช่วยลำดับมาให้ด้วยครับว่า ทำอะไร อย่างไร การจบขั้นตอนที่ว่านั้นผลลัพธ์ควรเป็นอย่างไร

[yodpao.b]

Code: Select all

Sub MacroAdvancedFilter()
On Error Resume Next

    Set Newbook = Workbooks.Add
    Range("A5").Select  '¡Ãͧ¢éÍÁØÅ
    Workbooks("Overtime.xls").Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("A6:AC65536"). _
        AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Workbooks("Overtime.xls") _
        .Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Range("X2:X3"), CopyToRange:=Range("A5"), _
        Unique:=False
                
    If Range("A6") <> "" Then
                                                            
                Windows("Overtime.xls").Activate   '   ¡ÒÃ copy
                Sheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ").Select
                Rows("4:6").Select
                Selection.Copy
                Application.WindowState = xlMinimized
                Newbook.Activate
                Range("A3").Select
                ActiveSheet.Paste
                Range("A1").Select
                Application.CutCopyMode = False
                
    Columns("A:AC").Select   '   ¨Ñ´¤ÇÒÁ¡ÇéÒ§àªÅ
    Columns("A:AC").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 18.86
    Columns("F:F").ColumnWidth = 14.57
    Columns("G:G").ColumnWidth = 11.86
    Columns("H:H").ColumnWidth = 17
    Columns("I:I").ColumnWidth = 18
    Range("A1").Select     
                                          MsgBox "·èÒ¹·Ó¡Òà Export File à´×͹  " & Range("X6") & "   àÃÕºÂÃéÍÂáÅéÇ ¡ÃØ³Ò Save File ´éÇÂ", vbExclamation, "Export File"
                                         Call MacroSaveAs
                            
            Else
                MsgBox "à´×͹·Õè·èÒ¹àÅ×Í¡äÁèÁÕã¹°Ò¹¢éÍÁÙÅ", vbExclamation, "Export File"
                ActiveWindow.Close False
            End If
End Sub

หลังจากการ Run Code นี้ ในช่วงขณะที่ Run ไฟล์ excel ได้ลงไปอยุ่นะตำแหน่ง ทาร์บารด้านล่างดังรูปด่านล่าง
ต้องลาก Mouse ไปคลิก Excel ในทาร์บาร จ฿งจะทำการ Run ต่อได้

Untitled3.gif