อยากทราบ transfer to excel ที่กำหนดเป็น rang
กระทู้เก่าบอร์ด อ.Yeadram

 3,130   2
URL.หัวข้อ / URL
อยากทราบ transfer to excel ที่กำหนดเป็น rang

ผมขอสอบถามอาจารย์ เรื่องคำสั่ง Macro ที่ export query ไปไว้ที่ Excel ใน 1 sheet แต่ให้วางเป็นช่วง ซึ่งผมเห็นใน function TransferSpreadsheet / Outputto สามารถทำได้หรือไม่ครับ คือมี query มากกว่า 1 ชุด เช่นข้อมูลเพศชาย, หญิง แต่ต้องการให้ run marco เลย โดยกำหนดให้ทำการ export ทั้ง 2 query ไปไว้ใน 1 sheet เช่น ข้อมูลเพศชาย ไปไว้ที่ SHEET1 A1:B500 และ เพศหญิงไปไว้ที่ D1:E500

ผมอยากทราบว่านอกเหนือ function ทั้ง 2 ยังมี function ไหนอีกครับ

ขอบพระคุณอย่างยิ่ง

2 Reply in this Topic. Dispaly 1 pages and you are on page number 1

1 @R15073
ส่วนตัวไม่ค่อยได้ใช้ Excel ครับ และก็ไม่ค่อยใช้ Macro ในการใช้งาน MS Access เท่าไร่ด้วย เขียนแต่ VBA แต่มันก็เหมือนกันแหละครับ ผมจึงขอพูดในมุมของโค๊ดแล้วกันนะครับ

DoCmd.OutputTo:
ส่งเป็นไฟล์ฟอร์แมทนั้นๆไปเลย ไม่น่าจะกำหนด Range ได้

DoCmd.TransferSpreadsheet:
กำหนด Range ได้ เช่น A1:B500
แต่เท่าที่เคยทำ มันจะต้องเริ่มต้นที่ A1 เท่านั้น หากเป็น D1:E500 อย่างนี้ไม่น่าจะได้เช่นกัน
รูปแบบคำสั่ง:
DoCmd.TransferSpreadsheet _
Transfertype:=acExport, _
SpreadSheettype:=acSpreadsheetTypeExcel9, _
Tablename:="Table1", _
FileName:="C:\Book1.xlsx", _
Hasfieldnames:=True, _
Range:="Sheet1!A1:D500", _
UseOA:=False

(แต่หากคุณแค่ต้องการต่อ 2 คิวรี่ โดยไม่กำหนด Range แนะนำให้ใช้การ UNION กันก่อนแล้วค่อย Export ออกไปในครั้งเดียวเลย)

แต่หากจำเป็นต้องกำหนด Range แบบ ตารางนึงอยู่ซ้าย อีกตารางอยู่ขวา อะไรอย่างนั้นจริงๆ ก็มีอีกวิธีที่ผมเห็นเค้าทำกัน (ในบอร์ดนี้ อ.สุภาพ ได้เคยเขียนไว้แต่ผมหาไม่เจอแล้ว) คือการดึง ไลบรารี่ ของ MS Excel มาใช้ใน MS Access แล้วเขียนโค๊ดด้วยฟังก์ชั่นของ MS Excel ส่งกลับไปสั่งใน MS Excel อีกที ลักษณะการทำงานจะเป็นแบบ Write Line คือสั่งเขียนที่ละ Cell เลย แต่ตอนนี้ผมยังไม่ได้เขียนโค๊ดเลย อยู่แค่ในหัวอย่างสะเปะสะปะ ไว้เรียบเรียงได้ ผมจะเข้ามาเขียนต่อให้ดูแล้วกันนะครับ

ปล. หากท่านใดมีวิธีดีๆ ก็ขอความรู้ด้วยนะครับ
2 @R15103
ตามสัญญาครับ ไม่ทราบเจ้าของกระทู้ยังตามอยู่หรือเปล่า แต่เขียนไปเลยแล้วกัน
คือผมไปเจอคำสั่งนึง น่าสนใจกว่า คือใช้การ Copy Recordset ลงในไฟล์ MS Excel ได้เลย ซึ่งทำให้เร็วกว่าการทำแบบที่ละ Line มากๆ ผมลองกับระดับหมื่นเรคคอร์ดก็เร็วดีครับ เอาเป็นว่าลองดูแล้วกันนะครับ ฟังก์ชั่นนี้ผมเขียนเองนะครับ อาจจะมีปัญหาได้ เพราะผมทดสอบได้นิดหน่อยเอง หากมีปัญหาลองปรับแก้ดูนะครับ

1. ในหน้าต่าง VBE เพิ่มไลบารี่ ใน References ชื่อ Microsoft Excel 14.0 Object Library (อาจไม่ใช่ 14.0 หาก Office เป็นเวอร์ชั่นอื่นๆ)

2. เขียนโค๊ดลงใน Module ดังนี้:
Public Function Mdb2Xls(mdb_Table As String, xls_pathName As String, _
                                    Optional Range_Cell As String = "A1", _
                                    Optional SheetNum As Integer = 1, _
                                    Optional Name_Field As Boolean = True, _
                                    Optional FreezePanes_Row As Boolean = False, _
                                    Optional Columns_AutoFit As Boolean = True, _
                                    Optional Cls_OldDATA As Boolean = True, _
                                    Optional AutoClose_xls As Boolean = True)

    Dim dbs As DAO.Database, rst As DAO.Recordset
    Dim xlApp As Excel.Application, xlBook As Excel.Workbook
    Dim fld As Field, a As Integer, StrSQL As String
    
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(mdb_Table)
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open(xls_pathName)
    Range_Cell = UCase(Range_Cell)
    
On Error GoTo Err_Exit_Online
    Dim TT As Integer
    TT = xlBook.Worksheets.Count ' นับจำนวน Sheet ที่มีในไฟล์ MS Excel
    '--------------หากกำหนดชื่อ Sheet เกินเลขที่มีอยู่ในไฟล์ MS Excel--------------    
    If SheetNum > TT Then
        Dim i As Integer, ia As Boolean
        For i = 1 To TT
            If xlBook.Sheets(i).Name = "Sheet" & SheetNum Then
               ia = False
               Exit For
            Else
               ia = True
            End If
        Next
        If ia = True Then
            xlBook.Worksheets.Add After:=xlBook.Sheets(TT)
            xlBook.Sheets(TT + 1).Name = "Sheet" & SheetNum
        End If
    End If
    '-----------------------------------------------------------------
    DoCmd.Echo False, "Exporting, Please wait..." 'ล็อคหน้าต่าง MS Access ไม่ให้ตอบสนอง ขณะทำคำสั่งอยู่

    xlBook.Worksheets("Sheet" & SheetNum).Select
    xlBook.Worksheets("Sheet" & SheetNum).Range(Range_Cell).Select
    '----------------แยกชื่อเซลว่ามีอักษรกี่ตัว เช่น A2 หรือ DB2--------------------
    For i = 1 To Len(Range_Cell)
        If IsNumeric(Mid(Range_Cell, i, 1)) Then
            Exit For
        End If
    Next
    Dim TTT As Integer, ib As Integer
        If i - 1 = 1 Then
            TTT = (Asc(Mid(Range_Cell, 1, 1)) - 64)
        ElseIf i - 1 = 2 Then
            For ib = 1 To i - 1
               If ib = 1 Then
                    TTT = (Asc(Mid(Range_Cell, ib, 1)) - 64) * 26
               Else
                    TTT = TTT + (Asc(Mid(Range_Cell, ib, 1)) - 64)
               End If
            Next
        End If
    '-----------------------------------------------------------------
    If AutoClose_xls Then xlApp.Visible = False Else xlApp.Visible = True 'แสดงการเปิดไฟล์ MS Excel หรือไม่
    '-------------คำสั่งการ Clear ค่าต่างๆ ที่ค้างอยู่ใน Cell ก่อนใส่ค่าใหม่-------------
    If Cls_OldDATA Then
        xlApp.Range(Range_Cell).CurrentRegion.Clear
        xlApp.Range(Range_Cell).CurrentRegion.ClearHyperlinks
        xlApp.Range(Range_Cell).CurrentRegion.ClearNotes
        xlApp.Range(Range_Cell).CurrentRegion.ClearFormats
        xlApp.Range(Range_Cell).CurrentRegion.ClearComments
        xlApp.Range(Range_Cell).CurrentRegion.ClearOutline
        xlApp.Range(Range_Cell).CurrentRegion.ClearContents
    End If
    '-----------------------------------------------------------------
    If Name_Field Then 'แยกคำสั่งการกำหนดค่าหากต้องการชื่อฟิลด์ด้วย
    '-------คำสั่งก๊อปปี้ค่าใน ตัวแปร rst Recordset ลงในตำแหน่ง Cell ที่กำหนด--------
        xlApp.Cells(CInt(Mid(Range_Cell, i)) + 1, TTT).CopyFromRecordset rst
    '-----------------------------------------------------------------
        a = TTT
        For Each fld In rst.Fields 'นำชื่อฟิลด์ของตารางหรือคิวรี่ มาใส่ค่าในไฟล์ MS Excel แบบ Write Line และเซ็ทค่าฟอร์นต่างๆ
            xlApp.Cells(CInt(Mid(Range_Cell, i)), a).Value = fld.Name
            xlApp.Cells(CInt(Mid(Range_Cell, i)), a).Font.Bold = True
            xlApp.Cells(CInt(Mid(Range_Cell, i)), a).HorizontalAlignment = 3 '-4108 (เซ็ทกึ่งกลาง)
            'xlApp.Cells(CInt(Mid(Range_Cell, i)), a).Font.Name = "Tahoma"
            'xlApp.Cells(CInt(Mid(Range_Cell, i)), a).Font.Color = RGB(255, 0, 0)
            'xlApp.Cells(CInt(Mid(Range_Cell, i)), a).Font.Underline = True
            a = a + 1
        Next fld
    Else ' หากไม่ต้องการชื่อฟิลด์
        xlApp.Cells(CInt(Mid(Range_Cell, i)), TTT).CopyFromRecordset rst
        xlApp.Rows(CInt(Mid(Range_Cell, i))).Font.Bold = False
    End If

    If Columns_AutoFit Then xlApp.ActiveSheet.Columns.AutoFit ' ขยายความกว้างเซลตามข้อมูล
    '-------------กำหนดตำแหน่ง เมนู FreezePanes (เซลอยู่กับที่)----------------
    If FreezePanes_Row Then
        xlApp.ActiveWindow.FreezePanes = False
        xlApp.Rows(CInt(Mid(Range_Cell, i)) + 1).Select
        xlApp.ActiveWindow.FreezePanes = True
    End If
    '-----------------------------------------------------------------
    xlApp.Range(Range_Cell).Select
    Set dbs = Nothing: rst.Close: Set rst = Nothing
    xlBook.Save
    If AutoClose_xls Then xlApp.Quit: MsgBox "Export " & mdb_Table & " To " & xls_pathName & " Complete"
    Set xlBook = Nothing: Set xlApp = Nothing
    DoCmd.Echo True 'กำหนดหน้าจอ MS Access ให้ตอบสนองเหมือนเดิม
Exit_Exit_Online:
    Exit Function
Err_Exit_Online:
    xlApp.Quit
    MsgBox "(!) มีความผิดพลาด ซึ่งอาจเกิดจากความผิดพลาดในการกำหนดค่าให้กับฟังก์ชั่น" & Chr(13) & "โปรดตรวจสอบการใส่ค่าฟังก์ชั่นอีกครั้ง", , "ผิดพลาด"
    Resume Exit_Exit_Online:
End Function



Mdb2Xls("mdb_Table", "xls_pathName", "Range_Cell", SheetNum, Name_Field, FreezePanes_Row, Columns_AutoFit, Cls_OldDATA, AutoClose_xls)

ความหมาย:
mdb_Table       :Required(String). ชื่อตาราง หรือคิวรี่ ที่ต้องการส่งออกข้อมูล
xls_pathName    :Required(String). ชีอพาธไฟล์ MS Excel ที่ต้องการนำเข้าข้อมูล
Range_Cell      :Optional(String). ชื่อตำแหน่งเซลใน MS Excel ที่ต้องการใส่ เช่น "B5" หากไม่กำหนด ค่าจะเป็น "A1"
SheetNum        :Optional(Number). เลขหน้าชีส (Sheet1, 2, 3,...) หากไม่กำหนดค่า จะเป็น 1 (Sheet1)
Name_Field      :Optional(True/False). ใส่ชื่อฟิลด์ของตาราง ลงในไฟล์ MS Excel หรือไม่ หากไม่กำหนด ค่าจะเป็น True
FreezePanes_Row :Optional(True/False). กำหนดเซลเป็นเมนูหรือไม่ หากไม่กำหนด ค่าจะเป็น False
Columns_AutoFit :Optional(True/False). ขยายความกว้างของเซลตามข้อมูลหรือไม่ หากไม่กำหนด ค่าจะเป็น True
Cls_OldDATA     :Optional(True/False). ล้างค่า Format ที่ค้างอยู่ในเซลหรือไม่ หากไม่กำหนด ค่าจะเป็น True
AutoClose_xls   :Optional(True/False). ปิดไฟล์ MS Excel เมื่อลงข้อมูลเสร็จแล้วหรือไม่ หากไม่กำหนด ค่าจะเป็น True

- การใช้งาน สมมุติมีไฟล์ MS Excel ชื่อ Book1.xlsx อยู่ที่ C:\ เขียนโค๊ดใน Event > On Click ของปุ่มบนฟอร์ม:

Call Mdb2Xls("Table1", "C:\Book1.xlsx", "F10", 2, True, False, True, True, True)

"Table1"        = ชื่อตาราง หรือคิวรี่ ที่ต้องการส่งออกข้อมูล
"C:\Book1.xlsx" = ชื่อพาธไฟล์ MS Excel ที่ต้องการนำเข้าข้อมูล
"F10"           = ชื่อตำแหน่งเซลที่ต้องการเริ่มต้น
2               = เลขหน้าชีสที่ต้องการ (Sheet2)
True            = ใส่ชื่อฟิลด์ของตารางลงไปด้วย
False           = ไม่กำหนดหัวข้อเซลเป็นแบบ Freeze Panes
True            = ขยายความกว้างของเซลตามข้อมูล
True            = ล้างค่า Format ที่ค้างไว้ในไฟล์ MS Excel หากมี
True            = ไม่แสดงการเปิดไฟล์ MS Excel ขณะส่งออกข้อมูล

ปล. จากโจทย์ คุณกระต่าย คุณอาจเขียนโค๊ดสั่งงาน 2 ครั้งที่ปุ่มดังนี้:

Call Mdb2Xls("query1", "C:\Book1.xlsx", "A1", 1)
Call Mdb2Xls("query2", "C:\Book1.xlsx", "D1", 1, , , , False)

ประมาณนี้ครับ ลองศึกษาดูแล้วกัน ผมพยายามเขียนอธิบายคำสั่งไว้ แต่ได้เท่านี้เพราะบางอย่างก็อธิบายเป็นคำสั้นๆยากมากๆ คำสั่งต่างๆหาได้จากเว็บอยู่แล้ว ผมเรียบเรียงขั้นตอนมาให้ ลองทดสอบดูแล้วกันครับ เผื่อเป็นประโยชน์กับผู้อื่นด้วยครับ (เมื่อยครับ ไปแล้ว)
@ ประกาศใช้งานเว็บบอร์ดใหม่ => บอร์ดเรียนรู้ Access สำหรับคนไทย
แล้วจะใส่ลิ้งอ้างอิงมาที่โพสต์เก่านี้หรือไม่ก็ตามสะดวกครับ
Time: 0.3226s