🔊 โปรดทราบ Image
  1. กรุณาอ่านกฎการใช้บอร์ด (Forum rules) ในตำแหน่งด้านบนของแต่ละบอร์ดครับ Image
  2. การสมัครสมาชิกเพื่อโพสต์คำถาม ดาวน์โหลดไฟล์แนบไปศึกษา ทำตามขั้นตอนด้านล่างครับ
    1. สมัครสมาชิก ดูขั้นตอนตาม Link นี้ครับ => สมัครสมาชิก กรณีลืมรหัสผ่านสามารถรับรหัสใหม่ได้ที่นี่ครับ => Reset รหัสผ่านImage
    2. Login เข้าระบบโดยคลิก Login ตรงมุมขวาบนของหน้านี้ Image กรณีมีปัญหาในการเข้าใช้งาน คลิก Link นี้เพื่อแจ้งผู้ดูแลระบบครับ => ติดต่อผู้ดูแลระบบ
  3. เมื่อ Login แล้วสามารถกำหนดการตั้งค่าส่วนตัว เช่นตั้งค่าภาษาเป็นไทยหรืออังกฤษได้ที่ Link นี้ครับ => ตั้งค่าส่วนตัว Image
  4. วิธีการตั้งและตอบกระทู้ดูได้ที่ Link นี้ครับ => วิธีการตั้งและตอบกระทู้ Image
  5. การจัดรูปแบบตัวอักษรด้วย bbcode ในช่องแสดงความคิดเห็นดูได้ที่ Link นี้ครับ => จัดรูปแบบตัวอักษร และสามารถกำหนดขนาดตัวอักษรใน Browser ได้ที่นี่ครับ => กำหนดขนาดตัวอักษรใน Browser Image

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

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

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

#1

Post by primeval147 » Fri Jan 19, 2018 2:30 pm

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 ได้ไหมครับ

logic
Silver
Silver
Posts: 655
Joined: Thu Mar 18, 2010 1:57 pm

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

#2

Post by logic » Fri Jan 19, 2018 4:19 pm

ลองบันทึกการ Save As แล้วนำโค้ดมาปรับได้ครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#3

Post by primeval147 » Fri Jan 19, 2018 4:59 pm

Save as เหมือนจะออกทั้งหมด แต่ว่าใน code ออกเฉพาะทีเลือกครับ ผมไม่แน่ใจบรรทัดไหนทำให้ PDF ทำงาน

User avatar
snasui
Site Admin
Site Admin
Posts: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#4

Post by snasui » Fri Jan 19, 2018 9:58 pm

:D แนบตัวอย่างไฟล์ ตัวอย่างคำตอบที่ต้องการมาด้วยจะได้สะดวกในการตอบ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#5

Post by primeval147 » Mon Jan 22, 2018 9:17 am

ร่วมรายชื่อตัวแทนและนายหน้า - 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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#6

Post by snasui » Mon Jan 22, 2018 10:56 pm

: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: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#7

Post by primeval147 » Tue Jan 23, 2018 9:23 pm

ขอบคุณครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#8

Post by primeval147 » Mon Jan 29, 2018 4:26 pm

รบกวนแก้ไข 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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#9

Post by snasui » Mon Jan 29, 2018 6:06 pm

:D แนบไฟล์ล่าสุดมาด้วยจะได้สะดวกในการทดสอบครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#10

Post by primeval147 » Tue Jan 30, 2018 11:07 am

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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#11

Post by snasui » Tue Jan 30, 2018 5:31 pm

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

ในเบื้องต้นลอง Run ทีละ Step ด้วยการกดแป้น F8 แล้วสังเกตดูว่าบรรทัดใดทำให้เกิด Error ส่งผลให้ไป Run บรรทัดภายใต้ errHandler: ให้แก้ที่บรรทัดนั้นหรือหากติดปัญหาใดให้สอบถามมาอีกรอบครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#12

Post by primeval147 » Tue Jan 30, 2018 7:10 pm

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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#13

Post by snasui » Tue Jan 30, 2018 8:12 pm

:D ช่วย Debug และลองแก้มาตามที่ผมแจ้งไปในโพสต์ที่ #11 ด้วยครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#14

Post by primeval147 » Wed Jan 31, 2018 1:04 am

หลังจากผม 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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#15

Post by snasui » Wed Jan 31, 2018 6:39 am

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

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

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

การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#16

Post by primeval147 » 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
You do not have the required permissions to view the files attached to this post.

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#17

Post by primeval147 » Wed Jan 31, 2018 1:59 pm

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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#18

Post by snasui » 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

primeval147
Member
Member
Posts: 27
Joined: Sun Dec 20, 2015 12:44 am

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

#19

Post by primeval147 » Wed Jan 31, 2018 11:04 pm

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: 22755
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Contact:

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

#20

Post by snasui » Wed Jan 31, 2018 11:08 pm

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

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

Post Reply