Nhờ sửa code xuất ra file PDF

[saobekhonglac]

Chào anh/chị.

Em đang sử dụng code bên dưới xuất ra Excel theo điều kiện, giờ em muốn xuất ra dạng PDF luôn, nhờ anh/chị sửa giúp em code với.

Cám ơn anh/chị nhiều.


Sub Mail1()
Dim dic As Object, rngSrc As Range, wkbNew As Workbook
Dim aIDs, n As Long
Dim sFolder As String, FileName As String, SheetName As String
sFolder = ThisWorkbook.Path & "\"
Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:U65000")
aIDs = rngSrc.Offset(1).Columns("T:U").Value
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
rngSrc.Range("IV1").Value = rngSrc.Range("T1").Value
For n = 1 To UBound(aIDs, 1)
If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
SheetName = aIDs(n, 1): FileName = aIDs(n, 1) 'sua so 1
If Not dic.Exists(SheetName) Then
dic.Add SheetName, Empty
Set wkbNew = Workbooks.Add(1)
wkbNew.Sheets(1).Name = SheetName
rngSrc.Range("IV2").Value = "'=" & SheetName
rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
wkbNew.Close False
End If
End If
Next
Application.ScreenUpdating = True
rngSrc.Range("IV1:IV2").ClearContents
If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"

 

[Ai_Ma_Biet]

Cái này tôi nghĩ không sửa code được mà phải viết 1 code mới thôi.

 

[huuthang_bd]

Chào anh/chị.

Em đang sử dụng code bên dưới xuất ra Excel theo điều kiện, giờ em muốn xuất ra dạng PDF luôn, nhờ anh/chị sửa giúp em code với.

Cám ơn anh/chị nhiều.


Sub Mail1()
Dim dic As Object, rngSrc As Range, wkbNew As Workbook
Dim aIDs, n As Long
Dim sFolder As String, FileName As String, SheetName As String
sFolder = ThisWorkbook.Path & "\"
Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:U65000")
aIDs = rngSrc.Offset(1).Columns("T:U").Value
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
rngSrc.Range("IV1").Value = rngSrc.Range("T1").Value
For n = 1 To UBound(aIDs, 1)
If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
SheetName = aIDs(n, 1): FileName = aIDs(n, 1) 'sua so 1
If Not dic.Exists(SheetName) Then
dic.Add SheetName, Empty
Set wkbNew = Workbooks.Add(1)
wkbNew.Sheets(1).Name = SheetName
rngSrc.Range("IV2").Value = "'=" & SheetName
rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
wkbNew.Close False
End If
End If
Next
Application.ScreenUpdating = True
rngSrc.Range("IV1:IV2").ClearContents
If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"

Thay

wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook

Bằng

wkbNew.Sheets(1).ExportAsFixedFormat 0, sFolder & FileName, 0, True, False, , , False

Nếu gặp lỗi như hình sau thì tìm và cài SaveAsPDFandXPS

TB: Code thì đặt trong thẻ code chứ để vậy nhìn là thấy không muốn xem rồi.