กระทู้เก่าบอร์ด อ.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 ไหนอีกครับ
ขอบพระคุณอย่างยิ่ง
ผมอยากทราบว่านอกเหนือ function ทั้ง 2 ยังมี function ไหนอีกครับ
ขอบพระคุณอย่างยิ่ง
2 Reply in this Topic. Dispaly 1 pages and you are on page number 1
2 @R15103
ตามสัญญาครับ ไม่ทราบเจ้าของกระทู้ยังตามอยู่หรือเปล่า แต่เขียนไปเลยแล้วกัน
คือผมไปเจอคำสั่งนึง น่าสนใจกว่า คือใช้การ Copy Recordset ลงในไฟล์ MS Excel ได้เลย ซึ่งทำให้เร็วกว่าการทำแบบที่ละ Line มากๆ ผมลองกับระดับหมื่นเรคคอร์ดก็เร็วดีครับ เอาเป็นว่าลองดูแล้วกันนะครับ ฟังก์ชั่นนี้ผมเขียนเองนะครับ อาจจะมีปัญหาได้ เพราะผมทดสอบได้นิดหน่อยเอง หากมีปัญหาลองปรับแก้ดูนะครับ
1. ในหน้าต่าง VBE เพิ่มไลบารี่ ใน References ชื่อ Microsoft Excel 14.0 Object Library (อาจไม่ใช่ 14.0 หาก Office เป็นเวอร์ชั่นอื่นๆ)
2. เขียนโค๊ดลงใน Module ดังนี้:
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)
ประมาณนี้ครับ ลองศึกษาดูแล้วกัน ผมพยายามเขียนอธิบายคำสั่งไว้ แต่ได้เท่านี้เพราะบางอย่างก็อธิบายเป็นคำสั้นๆยากมากๆ คำสั่งต่างๆหาได้จากเว็บอยู่แล้ว ผมเรียบเรียงขั้นตอนมาให้ ลองทดสอบดูแล้วกันครับ เผื่อเป็นประโยชน์กับผู้อื่นด้วยครับ (เมื่อยครับ ไปแล้ว)
คือผมไปเจอคำสั่งนึง น่าสนใจกว่า คือใช้การ 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)
ประมาณนี้ครับ ลองศึกษาดูแล้วกัน ผมพยายามเขียนอธิบายคำสั่งไว้ แต่ได้เท่านี้เพราะบางอย่างก็อธิบายเป็นคำสั้นๆยากมากๆ คำสั่งต่างๆหาได้จากเว็บอยู่แล้ว ผมเรียบเรียงขั้นตอนมาให้ ลองทดสอบดูแล้วกันครับ เผื่อเป็นประโยชน์กับผู้อื่นด้วยครับ (เมื่อยครับ ไปแล้ว)
Time: 0.3226s
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 เลย แต่ตอนนี้ผมยังไม่ได้เขียนโค๊ดเลย อยู่แค่ในหัวอย่างสะเปะสะปะ ไว้เรียบเรียงได้ ผมจะเข้ามาเขียนต่อให้ดูแล้วกันนะครับ
ปล. หากท่านใดมีวิธีดีๆ ก็ขอความรู้ด้วยนะครับ