XuatPDF.bas

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