:D snasui.com ยินดีต้อนรับ :D
ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย :thup: สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ :arrow: ระบุ Version ของ Excel
:!: โปรดทราบ :!:
  1. กรุณาอ่านกฎการใช้บอร์ด (Forum rules) ในตำแหน่งด้านบนของแต่ละบอร์ด
  2. การสมัครสมาชิก การ Login การกู้คืนรหัสผ่าน
    1. สมัครสมาชิกดูขั้นตอนได้ที่ :arrow: สมัครสมาชิก
    2. Login เข้าระบบโดยคลิกปุ่ม Login ตรงมุมขวาบนของหน้านี้ :roll:
    3. การ Login ผ่าน Facebook ดูวิธีที่ :arrow: Login ผ่าน Facebook
    4. ลืมรหัสผ่านสามารถรับรหัสใหม่ได้ที่ :arrow: Reset รหัสผ่าน
  3. มีปัญหาการใช้งาน แจ้งผู้ดูแลระบบได้ที่ :arrow: ติดต่อผู้ดูแลระบบ
  4. กำหนดการตั้งค่าส่วนตัว เช่นตั้งค่าภาษาเป็นไทยหรืออังกฤษดูได้ที่ :arrow: ตั้งค่าส่วนตัว
  5. การตั้งและตอบกระทู้ดูได้ที่ :arrow: วิธีการตั้งและตอบกระทู้
  6. การจัดรูปแบบตัวอักษรด้วย bbcode ในช่องแสดงความคิดเห็นดูได้ที่ :arrow: จัดรูปแบบตัวอักษร
  7. กำหนดขนาดตัวอักษรใน Browser ดูได้ที่ :arrow: กำหนดขนาดตัวอักษรใน Browser

สอบถามการแปลงการ code เดิม PDF ให้ออก excel

ฟอรัมถาม-ตอบปัญหาการใช้งาน MS Excel and VBA
Forum rules
  1. ไม่อนุญาตให้ใช้ภาษาแชทในการถามและตอบปัญหา ไม่ใช้คำว่า "คับ" หรือ "อ่ะครับ" แทนคำว่า "ครับ" ไม่ใช้คำว่า "เด๋ว" แทนคำว่า "เดี๋ยว" เป็นต้น เนื่องจากเมื่อแปลเป็นภาษาต่างประเทศแล้วจะให้ความหมายผิดไปจากที่ควรจะเป็น
  2. ห้ามถามโดยระบุชื่อผู้ตอบและต้องตั้งชื่อกระทู้ให้สื่อถึงปัญหาที่จะถาม ไม่ตั้งชื่อว่า ช่วยด้วยครับ, มีปัญหามาปรึกษาครับ เป็นต้น
  3. กรุณาอธิบายปัญหาและระบุคำตอบที่ต้องการมาในกระทู้ด้วยเสมอถึงแม้จะอธิบายไว้ในไฟล์แนบแล้วก็ตาม ทั้งนี้เพื่ออำนวยความสะดวกแก่เพื่อนสมาชิกในการค้นหาข้อมูล
  4. กรุณาแนบไฟล์ตัวอย่างพร้อมแสดงคำตอบที่ถูกต้องมาในไฟล์ด้วยเพื่อให้ง่ายต่อการทำความเข้าใจและสะดวกต่อการตอบคำถาม (ขนาดไฟล์ไม่เกิน 500Kb ขนาดภาพไม่เกิน 800*600 Pixel) ไม่แนบเป็น Link มาจากแหล่งอื่นที่อาจจะถูกลบทิ้งไปโดยต้นทางในภายหลัง นอกจากนี้ไม่ควรแนบไฟล์ที่มีข้อมูลสำคัญอันก่อให้เกิดความเสียหายกับตนเองและผู้อื่น
  5. กรณีเป็นคำถามเกี่ยวกับ Programming เช่น VBA, VB.Net, C#, SQL ฯลฯ ต้องลองเขียนมาเองก่อนเสมอ ถามเฉพาะที่ติดปัญหา ระบุ Module, Procedure ที่ติดปัญหาให้ชัดเจน กรุณาโพสต์ Code ให้แสดงเป็น Code คือเปิดด้วย [code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
  6. กรุณาแจ้งผลการใช้งานเมื่อได้รับคำตอบว่าตรงกับความต้องการหรือไม่
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#1

Post by primeval147 »

Code: Select all

Sub Button28_PDF()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub
อยากสอบถามครับ เราจะปรับ code ดังกล่าวตัวนี้ให้ออก เป็น excel ได้ไหมครับ
User avatar
logic
Gold
Gold
Posts: 1506
Joined: Thu Mar 18, 2010 1:57 pm
Excel Ver: 365

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#2

Post by logic »

ลองบันทึกการ Save As แล้วนำโค้ดมาปรับได้ครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#3

Post by primeval147 »

Save as เหมือนจะออกทั้งหมด แต่ว่าใน code ออกเฉพาะทีเลือกครับ ผมไม่แน่ใจบรรทัดไหนทำให้ PDF ทำงาน
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#4

Post by snasui »

:D แนบตัวอย่างไฟล์ ตัวอย่างคำตอบที่ต้องการมาด้วยจะได้สะดวกในการตอบ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#5

Post by primeval147 »

ร่วมรายชื่อตัวแทนและนายหน้า - Copy.xlsm
แนบแล้วครับ
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#6

Post by snasui »

:D ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub Button28_PDF()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
Dim shp As Shape
On Error GoTo errHandler


If InStr(Range("b5").value, "¹ÒÂ˹éÒ") > 0 Then
    lictype = "¹ÒÂ˹éÒ"
ElseIf InStr(Range("b5").value, "µÑÇá·¹") > 0 Then
    lictype = "µÑÇá·¹"
ElseIf InStr(Range("b5").value, "ÃèÇÁãºÍ¹Ø­Òµ") > 0 Then
    lictype = "ÃèÇÁãºÍ¹Ø­Òµ"
End If

codebranch = VBA.Left(Range("A1"), 3)
branchname = VBA.Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = VBA.Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".xlsx"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="Excel Files (*.xls*), *.xls*", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
'If myFile <> "False" Then
'    wsA.ExportAsFixedFormat _
'        Type:=xltyp, _
'        Filename:=myFile, _
'        Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, _
'        IgnorePrintAreas:=False, _
'        OpenAfterPublish:=False

ActiveSheet.Copy
For Each shp In ActiveSheet.Shapes
    shp.Delete
Next shp
ActiveSheet.Range("a1:a3").EntireRow.Delete
ActiveWorkbook.SaveAs myFile
ActiveWorkbook.Close False
    'confirmation message with file info
    MsgBox "Excel file has been created: " _
      & vbCrLf _
      & myFile
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file with the same name."
    Resume exitHandler
End Sub
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#7

Post by primeval147 »

ขอบคุณครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#8

Post by primeval147 »

รบกวนแก้ไข Error ให้หน่อยครับ พอดีผมไม่ได้ใช้ Code ตามอาจารย์ แต่รองปรับเป็นแบบอื่น จากคำถามเดิม แต่มีคำถามเพิ่มเติมดังนี้ครับ
1. พอดีจะลอง Export Excel ปุ่ม Marcro ปรากฎว่า Code มีอาการ ออก Excel ได้ และออกไม่ได้ โดย Error ตาม MsgBox "Could not create PDF file"

Code: Select all

Sub Button29_EXCEL()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

        If fname <> False Then
            'Copy the ActiveSheet to new workbook
            For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
            " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
            " Excel 2000-2003 Workbook (*.xls), *.xls," & _
            " Excel Binary Workbook (*.xlsb), *.xlsb", _
            FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
            End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Copy
                For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
         Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing

            End If
        End If
    End If
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub



2.

Code: Select all

 fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime,
ทำไมผมใช้ StrFile ไม่ได้ครับ

Code: Select all

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#9

Post by snasui »

:D แนบไฟล์ล่าสุดมาด้วยจะได้สะดวกในการทดสอบครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#10

Post by primeval147 »

snasui wrote: Mon Jan 29, 2018 6:06 pm :D แนบไฟล์ล่าสุดมาด้วยจะได้สะดวกในการทดสอบครับ
ร่วมรายชื่อตัวแทนและนายหน้า - Copy.xlsm
เพิ่มเติมคำถามครับ
1.code ดังกล่าว ออกเฉพาะ ตัวแทน วิภาวดี แต่พอลองเปลี่ยนเป็นนายหน้า หรือสาขาอื่น จะ error Cloud not create PDF แล้วเด้งขึ้นมาอีก workbook งาน fomat table เดิมทีนายหน้าต้องตารางสีเขียว กลายเป็นตารางเท่า
ตัวแทน_001_วิภาวดี_30_01_61.xlsm
อันนี้คือตัวหลักจาก Export Excel ครับ

เพราะได้มีการสั่งให้ลบบรรทัดบนที่แสดง ปุ่ม marcro ออกทั้งหมด แล้วมีการ paste special ตาม ตัวอย่างครับ
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#11

Post by snasui »

:D แก้ปัญหาไปที่ละเรื่องครับ จากไฟล์ ร่วมรายชื่อตัวแทนและนายหน้าควรแจ้งมาด้วย Code อยู่ที่ Module ไหนครับ

ในเบื้องต้นลอง Run ทีละ Step ด้วยการกดแป้น F8 แล้วสังเกตดูว่าบรรทัดใดทำให้เกิด Error ส่งผลให้ไป Run บรรทัดภายใต้ errHandler: ให้แก้ที่บรรทัดนั้นหรือหากติดปัญหาใดให้สอบถามมาอีกรอบครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#12

Post by primeval147 »

snasui wrote: Tue Jan 30, 2018 5:31 pm :D แก้ปัญหาไปที่ละเรื่องครับจากไฟล์ ร่วมรายชื่อตัวแทนและนายหน้าควรแจ้งมาด้วย Code อยู่ที่ Module ไหนครับ

ในเบื้องต้นลอง Run ทีละ Step ด้วยการกดแป้น F8 แล้วสังเกตดูว่าบรรทัดใดทำให้เกิด Error ส่งผลให้ไป Run บรรทัดภายใต้ errHandler: ให้แก้ที่บรรทัดนั้นหรือหากติดปัญหาใดให้สอบถามมาอีกรอบครับ
Module ที่ 8 ครับ
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#13

Post by snasui »

:D ช่วย Debug และลองแก้มาตามที่ผมแจ้งไปในโพสต์ที่ #11 ด้วยครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#14

Post by primeval147 »

หลังจากผม Filter นายหน้า ด้วย Macro ด้วยได้ลองทดสอบ ด้วย Macro Module8
ผลการทดสอบตาม Code ดังนี้

Code: Select all

Sub Button29_EXCEL()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

        If fname <> False Then
            'Copy the ActiveSheet to new workbook
            For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
            " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
            " Excel 2000-2003 Workbook (*.xls), *.xls," & _
            " Excel Binary Workbook (*.xlsb), *.xlsb", _
            FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
            End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Copy
                For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
Code Run มาถึงบรรทัด wsA.UsedRange.Copy ครับ หลังจากนั้น ตัดข้ามไปบรรทัด

Code: Select all

MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub
ก่อนการ Filter Macro สามารถ Export Excel ได้ตามปกติแต่พอลอง เปลี่ยนสาขา จะมีอาการตามด้านบนครับ
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#15

Post by snasui »

:D ติดเรื่องการ Merge เซลล์ ครับ

ในไฟล์ต้นทางมีการ Merge ไว้ที่ใดให้ยกเลิกการ Merge เสียก่อนแล้วค่อยดำเนินการ เมื่อดำเนินการเรียบร้อยแล้วค่อย Merge กลับเข้ามาใหม่

การ Merge เซลล์จะยุ่งยากลำบากในการจัดการมากกว่าปกติ หากเป็นไปได้ให้ใช้การจัด Format ด้วยวิธีอื่นเช่น Center Alignment เป็นต้น

การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#16

Post by primeval147 »

snasui wrote: Wed Jan 31, 2018 6:39 am :D ติดเรื่องการ Merge เซลล์ ครับ

ในไฟล์ต้นทางมีการ Merge ไว้ที่ใดให้ยกเลิกการ Merge เสียก่อนแล้วค่อยดำเนินการ เมื่อดำเนินการเรียบร้อยแล้วค่อย Merge กลับเข้ามาใหม่

การ Merge เซลล์จะยุ่งยากลำบากในการจัดการมากกว่าปกติ หากเป็นไปได้ให้ใช้การจัด Format ด้วยวิธีอื่นเช่น Center Alignment เป็นต้น

การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ
แก้ไขได้แล้วครับ ลบในส่วนของ error ออก แต่วทำไม ตาราง นายหน้าจากสีเขียวทำไม ถึงกลายเป็นสีเท่าครับ ในส่วนของตัวแทนไม่มีการเปลี่ยนสี
ร่วมรายชื่อตัวแทนและนายหน้า - Copy.xlsm
You do not have the required permissions to view the files attached to this post.
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#17

Post by primeval147 »

primeval147 wrote: Wed Jan 31, 2018 11:57 am
snasui wrote: Wed Jan 31, 2018 6:39 am :D ติดเรื่องการ Merge เซลล์ ครับ

ในไฟล์ต้นทางมีการ Merge ไว้ที่ใดให้ยกเลิกการ Merge เสียก่อนแล้วค่อยดำเนินการ เมื่อดำเนินการเรียบร้อยแล้วค่อย Merge กลับเข้ามาใหม่

การ Merge เซลล์จะยุ่งยากลำบากในการจัดการมากกว่าปกติ หากเป็นไปได้ให้ใช้การจัด Format ด้วยวิธีอื่นเช่น Center Alignment เป็นต้น

การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ
แก้ไขได้แล้วครับ ลบในส่วนของ error ออก แต่วทำไม ตาราง นายหน้าจากสีเขียวทำไม ถึงกลายเป็นสีเท่าครับ ในส่วนของตัวแทนไม่มีการเปลี่ยนสี
ร่วมรายชื่อตัวแทนและนายหน้า - Copy.xlsm
ร่วมรายชื่อตัวแทนและนายหน้า - Copy (1).xlsm
แนบ File ผิดอันครับ
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#18

Post by snasui »

:D ตัวอย่างการปรับ Code ครับ

Code: Select all

'...Other code
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Range("A1").UnMerge
                ActiveSheet.Range("B4").UnMerge
                ActiveSheet.Range("B5").UnMerge
                Application.Calculation = xlCalculationManual
                ActiveSheet.Copy
                Dim r As Range
                For Each wsA In ActiveWorkbook.Worksheets
                    For Each r In wsA.ListObjects(1).Range
                        r.value = r.value
                    Next r
                Next wsA
                Application.Calculation = xlCalculationAutomatic
                Set NewWb = ActiveWorkbook
                Rows("1:3").Select
                Selection.Delete Shift:=xlUp
                For i = 1 To 2
                   Range(Cells(i, 2), Cells(i, 14)).MergeCells = True
                Next i
                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing
                Range("A1:C1").Merge
                Range("B4:N4").Merge
                Range("B5:N5").Merge
            End If
'...Other code
primeval147
Member
Member
Posts: 32
Joined: Sun Dec 20, 2015 12:44 am

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#19

Post by primeval147 »

snasui wrote: Wed Jan 31, 2018 9:44 pm :D ตัวอย่างการปรับ Code ครับ

Code: Select all

'...Other code
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Range("A1").UnMerge
                ActiveSheet.Range("B4").UnMerge
                ActiveSheet.Range("B5").UnMerge
                Application.Calculation = xlCalculationManual
                ActiveSheet.Copy
                Dim r As Range
                For Each wsA In ActiveWorkbook.Worksheets
                    For Each r In wsA.ListObjects(1).Range
                        r.value = r.value
                    Next r
                Next wsA
                Application.Calculation = xlCalculationAutomatic
                Set NewWb = ActiveWorkbook
                Rows("1:3").Select
                Selection.Delete Shift:=xlUp
                For i = 1 To 2
                   Range(Cells(i, 2), Cells(i, 14)).MergeCells = True
                Next i
                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing
                Range("A1:C1").Merge
                Range("B4:N4").Merge
                Range("B5:N5").Merge
            End If
'...Other code
สอบถามเพิ่มเติม ครับ ทำไมการประมวลผลถึงนานครับ
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

Re: สอบถามการแปลงการ code เดิม PDF ให้ออก excel

#20

Post by snasui »

:D เข้าใจว่าเป็นเพราะ Table เนื่องจาก Table จะมีความเป็นอัตโนมัติค่อนข้างสูง ยกตัวอย่างเช่น คีย์สูตรในเซลล์เดียวก็จะเปลียนให้ทั้่งคอลัมน์ เช่นนี้เป็นต้นครับ

ก่อนการ Loop ก็มีการกำหนดให้การคำนวณเป็น Manual ไปแล้วแต่ยังพบว่าไม่ได้เร็วขึ้นแต่อย่างใดครับ
Post Reply