Created
January 17, 2018 08:25
-
-
Save DuongAQ/f762d0c2eee2bd3d770b1b5f63e79851 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Sub XuatPDF() | |
'Tìm dòng cuối bảng kê | |
Dim maxR As Integer | |
maxR = Sheet1.Range("F" & Rows.Count).End(xlUp).Value 'Luu ý cột cần xác định ở đây là cột F | |
'Xác định đường dẫn tới thư mục lưu kết quả | |
Set xSht = ActiveSheet | |
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) | |
If xFileDlg.Show = True Then | |
xFolder = xFileDlg.SelectedItems(1) | |
Else | |
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" | |
Exit Sub | |
End If | |
Application.ScreenUpdating = False 'Bỏ qua việc cập nhật màn hình | |
For x = 1 To maxR | |
With ActiveSheet.Range("M2") '<== Vị trí ô kết quả của Spin Button | |
.Value = x | |
Call Spinner_getData '<== Gọi lại câu lệnh lấy dữ liệu vào PXK sau mỗi lần thay đổi kết quả Spin | |
xFile = xFolder + "\" + xSht.Range("K4").Value + ".pdf" 'Xác định tên file sẽ được lưu, tên file lấy theo vị trí ô K4 | |
'Kiểm tra nếu tên file đã có sẵn, bị trùng tên | |
If Len(Dir(xFile)) > 0 Then | |
xYesorNo = MsgBox(xFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ | |
vbYesNo + vbQuestion, "File Exists") | |
On Error Resume Next | |
If xYesorNo = vbYes Then | |
Kill xFile | |
Else | |
MsgBox "if you don't overwrite the existing PDF, I can't continue." _ | |
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" | |
Exit Sub | |
End If | |
If Err.Number <> 0 Then | |
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ | |
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" | |
Exit Sub | |
End If | |
End If | |
Set xUsedRng = xSht.UsedRange | |
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then | |
'Lưu dưới định dạng file PDF | |
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFile, Quality:=xlQualityStandard | |
Else | |
MsgBox "The active worksheet cannot be blank" 'báo lỗi trường hợp bảng kê không có dữ liệu | |
Exit Sub | |
End If | |
End With | |
Next | |
Application.ScreenUpdating = True 'mở lại chế độ cập nhật màn hình sau khi hoàn thành vòng lặp | |
MsgBox "Well Done!" 'Thông báo hoàn thành công việc | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment