Export to Excel แล้วเราสามารถระบุชื่อเรื่องได้ไหมคะ

[มาลี]

ขอเรียนถามดังนี้นะคะ

หนูสั่ง Export ข้อมูลจาก Quary to Excel มันก็ได้ข้อมูลแบบตรงไปตรงมาได้ตามปกติค่ะ
แต่ทีนี้ หนูเกิดกิเลสหนาอยากให้ได้ไฟล์ Excel ที่มีการผสานเซล พร้อมระบุชื่อเรื่องลงไปด้วย
ถัดลงมาก็ให้เป็นแถวข้อมูลที่เรา Export ข้อมูลจาก Quary ตามปกติค่ะ

ไม่ทราบว่าสามารถทำได้หรือไม่อย่างไรคะ (ตามรูปตัวอย่างค่ะ)
ID : pbr39o-9aa58e
2018-07-12 18:15:24

[มาลี]

[สันติสุข]

โค๊ด: [Select]

    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "ชื่อคิวรี่", "พาธ\ไฟล์.xls หรือ .xlsx", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("พาธ\ไฟล์.xls หรือ .xlsx")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:E2").merge        ' Merge Cells
        xlApp.DisplayAlerts = True
    End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่อง"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With


[มาลี]

  เย้...ใช้ได้ตามที่ต้องการเลยค่ะอาจารย์

หนูนำโค๊ดไปปรับแต่งใช้ดังนี้ค่ะ

Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With

End Sub

แต่ เกิดปัญหาเล็กน้อยกับไฟล์ Excel ขณะตอนเปิดไฟล์ มีแจ้งประมาณว่า ไฟล์นี้ถูกเปิดอยู่แล้ว (ตามรูปค่ะ)
ไม่ทราบว่า ต้อแก้ไขอย่างไรคะ ขอบคุณค่ะอาจารย์

[ปิ่นณรงค์]

เพิ่มคำสั่งตอนท้ายครับเป็นแบบนี้
Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With
    xlApp.ActiveWorkbook.Close True
End Sub

[มาลี]

  เย้..ใช้ได้แล้ว ไม่ขึ้น error ตามในรูปอีกแล้วค่ะอาจารย์

ขอขอบคุณอาจารย์ทั้งสองท่านมากๆเลยนะคะ

[มาลี]

ขออนุญาตรบกวนเพิ่มเติมอีกนิดนะคะอาจารย์

จากคำสั่งดังกล่าว เราสามารระบุขนาดความกว้างของแต่ละเซลส์ ลงไปด้วยได้ไหมคะ

เช่น

เซลส์ A = 50 พิกเซล
เซลส์ B = 100 พิกเซล
เซลส์ C = 150 พิกเซล
เซลส์ D = 200 พิกเซล
เซลส์ E = 250 พิกเซล
เซลส์ F = 300 พิกเซล

ประมาณนี้ค่ะอาจารย์

[ปิ่นณรงค์]

Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With

With xlSheet
      .Columns("A").ColumnWidth = ......
      .Columns("B").ColumnWidth = ......
      .Columns("C").ColumnWidth = ......
      .Columns("D").ColumnWidth = ......
      .Columns("E").ColumnWidth = ......
      .Columns("F").ColumnWidth = ......
  End With   
    xlApp.ActiveWorkbook.Close True
End Sub

ตรง .....ลองกำหนดขนาดดูครับ
เพิ่มเติมนะครับถ้าอยากให้Column พอดีกับข้อความในเซล ก็ใส่เป็น
.Columns("A").EntireColumn.AutoFit

[มาลี]

ยอดเยี่ยมเลยค่ะ..ใช้ได้ตามที่ต้องการแล้ว

ขออภัยด้วยนะคะอาจารย์ ที่หนูเข้ามารายงานผลล่าช้า พอดีโพสคำถามทิ้งไว้ แล้วออกไปทำธุระ พึ่งจะกลับมาทดสอบค่ะอาจารย์

หนูเลือกใช้คำสั่ง .Columns("A").EntireColumn.AutoFit สะดวกสวยงามได้ตามที่ต้องการเลยค่ะ

จากการทดสอบดูหลายๆครั้งแล้ว พบว่า เจ้าเซลส์ที่ประสาน มันสร้างเพิ่มขึ้นมาใหม่เรื่อยๆครั้งละ 2 แถว ตามจำนวนครั้งที่เราสั่ง Export
เช่นจาก 2 เป็น 4 เป็น 6 เป็น 8 .... ทำอย่างไรจะให้มันอัพเดต ทับแทนที่เซลส์ที่ผสานตัวเดิมไปเลย โดยไม่ต้องสร้างเซลส์ผสานกันใหม่

ในส่วนของข้อมูลนั้น OK ไม่มีปัญหาค่ะ มันอัพเดตทับแทนที่ข้อมูลเดิมไปเลยค่ะ

[มาลี]

ตอนนี้ หนูแก้ปัญหาดังกล่าวได้แล้วค่ะ
โดยการเพิ่มคำสั่ง ให้มันลบไฟล์ Excel ตััวเดิมออกไปก่อน แล้วจึงตามด้วยคำสั่ง Export ไฟล์ตัวใหม่เข้าไปแทนที่
ปิดจ๊อบได้แล้วค่ะ

[TTT]

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

    Set xlSheet = xlWorkbook.ActiveSheet
    '-------------ตรวจสอบหากมีหัวเรื่องชื่อเดียวกันซ้ำก็ให้ข้ามการแทรกไป
    If xlSheet.Cells(1, 1).Value = "ชื่อหัวเรื่องที่ต้องการ" Then Exit Sub
    '-------------------------------------------------
    With xlSheet.Range("A1")

[มาลี]

ขอบคุณค่ะอาจารย์TTT
หนูจะลองนำไปปรับแก้ดูนะคะ

[มาลี]

ขออนุญาตถามเพิ่มต่อจากโค๊ดนี้ค่ะ

โค๊ด: [Select]

Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With

With xlSheet
      .Columns("A").ColumnWidth = ......
      .Columns("B").ColumnWidth = ......
      .Columns("C").ColumnWidth = ......
      .Columns("D").ColumnWidth = ......
      .Columns("E").ColumnWidth = ......
      .Columns("F").ColumnWidth = ......
  End With   
    xlApp.ActiveWorkbook.Close True
End Sub
จากโค๊ดข้างบนนี้ หากเราต้องการจะกำหนดขนาด/แบบอักษร เฉพาะแถวที่ 5
สมมติให้เป็น tahoma ขนาด 11 (เฉพาะแถวที่5) ต้องเพิ่มเติมคำสั่งอย่างไรคะ

หรือหากจะสั่งให้ทุแถวให้เป็น tahoma ขนาด 11 ทั้งหมดเลยต้องทำอย่างไรคะอาจารย์
 

[ปิ่นณรงค์]

สั่งให้ทุแถวให้เป็น tahoma ขนาด 11 ทั้งหมดเลยต้องทำอย่างไรคะ

Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With 
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With

With xlSheet
        .Font.Name = "Tahoma"
        .Font.Size = 11        'กำหนดขนาด
        .Font.Bold = false     'กำหนดตัวหนาหรือปกติ
        .Columns("A").ColumnWidth = ......
        .Columns("B").ColumnWidth = ......
        .Columns("C").ColumnWidth = ......
        .Columns("D").ColumnWidth = ......
        .Columns("E").ColumnWidth = ......
        .Columns("F").ColumnWidth = ......
  End With   
    xlApp.ActiveWorkbook.Close True
End Sub

[มาลี]

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

[ปิ่นณรงค์]

Private Sub Command0_Click()
    Dim xlApp           As Object
    Dim xlWorkbook      As Object
    Dim xlSheet         As Object
   
    DoCmd.TransferSpreadsheet acExport, , "Query1", "D:\ExportQuery1.xls", True
   
    Set xlApp = CreateObject("excel.application")
    Set xlWorkbook = xlApp.Workbooks.Open("D:\ExportQuery1.xls")
    Set xlSheet = xlWorkbook.activesheet

    With xlSheet.range("A1")
        .entirerow.insert -4121             ' Insert and Shift Row Down
        .entirerow.insert -4121             ' Insert and Shift Row Down
        xlApp.DisplayAlerts = False
        xlSheet.range("A1:F2").merge        ' Merge Cells (ผสานเซล A1:F2)
        xlApp.DisplayAlerts = True
    End With

With xlSheet.Cells.Font
         .name = "Tahoma"
         .FontStyle = "Regular"
         .Size = 11
End With
   
    With xlSheet.range("A1")
        .Value = "ชื่อหัวเรื่องที่ต้องการ"
        .Font.Name = "Tahoma"
        .Font.Size = 18
        .Font.Bold = True
        .HorizontalAlignment = -4108        ' Align Center
    End With


With xlSheet
      .Columns("A").ColumnWidth = ......
      .Columns("B").ColumnWidth = ......
      .Columns("C").ColumnWidth = ......
      .Columns("D").ColumnWidth = ......
      .Columns("E").ColumnWidth = ......
      .Columns("F").ColumnWidth = ......
  End With   
    xlApp.ActiveWorkbook.Close True
End Sub

ลองใหม่ครับได้ไหม

[มาลี]

  เย้.. สำเร็จแล้วค่ะอาจารย์

ขอขอบคุณมากๆเลยนะคะ

[iamkob]

สวัสดีครับ ผมมือใหม่ เข้ามาหาข้อมูล export query to excel เห็นกระทู้นี้ดูคล้ายกับที่ผมอยากทำ แต่อยากสอบถามเพิ่มเติมครับ
1 ถ้าเราจะจัดข้อความใน cell ให้ชิดซ้ายและขวา ให้ตัวเลขอะไรครับ
2 ถ้าต้องการตีกรอบเป็นตารางใช้คำสั่งอะไรครับ
3 ทำไมบางครั้ง พอ export ไปสักพัก excel จะ add sheet ใหม่แทน เช่นผมตั้งชื่อ sheet1 ให้ export ไปที่ sheet1 แต่พอ export ไป 3  หรือ 4 ครั้ง มันจะ add sheet11 แทนอะครับ
ขอคุณสำหรับคำตอบล่วงหน้าครับ