ตรวจสอบและปรับปรุงไฟล์ Excel ให้เร็วและเสถียรด้วย File Anatomy Add-in
เครื่องมือนี้ช่วยวิเคราะห์โครงสร้างไฟล์อย่างละเอียด เช่น สูตร, ลิงก์, PivotTable, Styles และ Objects
พร้อมฟังก์ชันล้างสิ่งเกินจำเป็นที่ทำให้ไฟล์ช้า หรือเสียหายได้ในคลิกเดียว
เหมาะสำหรับผู้ใช้ Excel ที่ต้องการควบคุมคุณภาพไฟล์อย่างมืออาชีพ
ทดลองใช้ Add-in
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
ระบุ Version ของ Excel 
โปรดทราบ สมัครสมาชิก
Login ผ่าน Facebook Reset รหัสผ่าน ติดต่อผู้ดูแลระบบ ตั้งค่าส่วนตัว วิธีการตั้งและตอบกระทู้ จัดรูปแบบตัวอักษร กำหนดขนาดตัวอักษรใน Browser
คำแสดงเจตนา[code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/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
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 ครับ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
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
Code: Select all
fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime,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")เพิ่มเติมคำถามครับ
แก้ปัญหาไปที่ละเรื่องครับ จากไฟล์ ร่วมรายชื่อตัวแทนและนายหน้าควรแจ้งมาด้วย Code อยู่ที่ Module ไหนครับModule ที่ 8 ครับsnasui wrote: Tue Jan 30, 2018 5:31 pm
ในเบื้องต้นลอง Run ทีละ Step ด้วยการกดแป้น F8 แล้วสังเกตดูว่าบรรทัดใดทำให้เกิด Error ส่งผลให้ไป Run บรรทัดภายใต้ errHandler: ให้แก้ที่บรรทัดนั้นหรือหากติดปัญหาใดให้สอบถามมาอีกรอบครับ
ช่วย Debug และลองแก้มาตามที่ผมแจ้งไปในโพสต์ที่ #11 ด้วยครับ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.CopyCode: Select all
MsgBox "Could not create PDF file"
Resume exitHandler
End Subแก้ไขได้แล้วครับ ลบในส่วนของ error ออก แต่วทำไม ตาราง นายหน้าจากสีเขียวทำไม ถึงกลายเป็นสีเท่าครับ ในส่วนของตัวแทนไม่มีการเปลี่ยนสีsnasui wrote: Wed Jan 31, 2018 6:39 am
ในไฟล์ต้นทางมีการ Merge ไว้ที่ใดให้ยกเลิกการ Merge เสียก่อนแล้วค่อยดำเนินการ เมื่อดำเนินการเรียบร้อยแล้วค่อย Merge กลับเข้ามาใหม่
การ Merge เซลล์จะยุ่งยากลำบากในการจัดการมากกว่าปกติ หากเป็นไปได้ให้ใช้การจัด Format ด้วยวิธีอื่นเช่น Center Alignment เป็นต้น
การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ
แนบ File ผิดอันครับprimeval147 wrote: Wed Jan 31, 2018 11:57 amแก้ไขได้แล้วครับ ลบในส่วนของ error ออก แต่วทำไม ตาราง นายหน้าจากสีเขียวทำไม ถึงกลายเป็นสีเท่าครับ ในส่วนของตัวแทนไม่มีการเปลี่ยนสีsnasui wrote: Wed Jan 31, 2018 6:39 am
ในไฟล์ต้นทางมีการ Merge ไว้ที่ใดให้ยกเลิกการ Merge เสียก่อนแล้วค่อยดำเนินการ เมื่อดำเนินการเรียบร้อยแล้วค่อย Merge กลับเข้ามาใหม่
การ Merge เซลล์จะยุ่งยากลำบากในการจัดการมากกว่าปกติ หากเป็นไปได้ให้ใช้การจัด Format ด้วยวิธีอื่นเช่น Center Alignment เป็นต้น
การ Debug ให้ยกเลิก On error resume...ออกไปก่อนจะได้ทราบว่า Error ที่เกิดขึ้นนั้นเป็น Error ลักษณะใดครับ
ร่วมรายชื่อตัวแทนและนายหน้า - Copy.xlsm
ตัวอย่างการปรับ 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
สอบถามเพิ่มเติม ครับ ทำไมการประมวลผลถึงนานครับsnasui wrote: Wed Jan 31, 2018 9:44 pm
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
เข้าใจว่าเป็นเพราะ Table เนื่องจาก Table จะมีความเป็นอัตโนมัติค่อนข้างสูง ยกตัวอย่างเช่น คีย์สูตรในเซลล์เดียวก็จะเปลียนให้ทั้่งคอลัมน์ เช่นนี้เป็นต้นครับ