Run-time error '9' subscript out of range (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

duongvanminh33

Thành viên mới
Tham gia
16/3/19
Bài viết
31
Được thích
3
Sub Button7_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String
Dim sPath As String
Dim i As Long
printFrom = Sheets("Sheet3").Range("I8")
printTo = Sheets("Sheet3").Range("I9")
Set OutApp = CreateObject("Outlook.Application")
For i = printFrom To printTo
Sheets("Sheet3").Range("I5") = i
ThisWorkbook.Sheets("Sheet3").Range("A1:D33").Select
Range("A1:D33").Copy
Workbooks.Add(xlWBATWorksheet).Sheets("Sheet1").Select
Range("A1:D33").Select
ActiveWorkbook.ActiveSheet.PasteSpecial
Columns("A:D").AutoFit
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'HAM NAY CHI DC DUNG TRONG RANGE
sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True _
, CreateBackup:=False
Workbooks.Add.Close Savechanges:=False
ActiveWorkbook.Close False

Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheets("Sheet3").Range("B12")
.cc = ""
.BCC = ""
.Subject = Sheets("Sheet3").Range("B9")
.HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
"<BR>Should you have any questions, do not hestitate to contact us." & _
"<BR><BR>Thanks & regards</B><BR>" & _
"</B>"
.Attachments.Add (sFile)
.Send
End With
Set OutMail = Nothing
Next i
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox "Success"

End Sub



Mình lại dính lỗi nãy, mình có xem xét lại từ đầu đến cuối mà vẫn báo lỗi sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
Mấy anh giúp em với ạ, em không hiểu sai chổ nào cả.
 
Không có Sheet3
 
Hình như đã có, vì bên trên các câu lệnh bên trên liên quan đến nó chưa lỗi: printFrom, printTo, Select
Lúc nãy em không xem các dòng code khác, giờ xem kỹ lại thì lỗi vẫn là do file hiện hành không có Sheet3.
File chứa code thì có Sheet3 nhưng file mới tạo bằng lệnh Workbooks.Add thì không có. Code trỏ đến Sheet3 (bằng SheetName) mà không xác định workbook nên mặc định trỏ đến workbook hiện hành. Khi thêm workbook mới thì workbook mới thành workbook hiện hành, code trỏ đến Sheet3 của workbook hiện hành nhưng không có -> lỗi.
Nếu muốn trỏ đến Sheet3 của workbook chứa code thì viết rõ ThisWorkbook.Sheets("Sheet3"). Ngoài ra, ActiveWorkbook.Path trong dòng lệnh đó luôn trả về.chuỗi rỗng do ActiveWorkbook là workbook chưa được save.
@Chủ topic: Nên tạo thói quen khi trỏ đến đối tượng bằng tên thì chỉ rõ đối tượng cha. Thói quen này giúp code rõ ràng hơn và hạn chế lỗi hoặc code thực thi không đúng ý đồ của người viết code. Lỗi còn biết để mà sửa chứ chạy sai mà không phát hiện được thì hậu quả khôn lường.
 
Lúc nãy em không xem các dòng code khác, giờ xem kỹ lại thì lỗi vẫn là do file hiện hành không có Sheet3.
File chứa code thì có Sheet3 nhưng file mới tạo bằng lệnh Workbooks.Add thì không có. Code trỏ đến Sheet3 (bằng SheetName) mà không xác định workbook nên mặc định trỏ đến workbook hiện hành. Khi thêm workbook mới thì workbook mới thành workbook hiện hành, code trỏ đến Sheet3 của workbook hiện hành nhưng không có -> lỗi.
Như vậy phải sửa ActiveWokbook thành ThisWorkbook ở câu này:
sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"

Ngoài ra câu này cũng sẽ lỗi vì vừa Add vừa Close (2 phương thức)
Workbooks.Add.Close Savechanges:=False

Và câu này cũng có nguy cơ lỗi vì không biết workbook nào
ActiveWorkbook.Close False
 
Sub Button7_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String
Dim sPath As String
Dim i As Long
printFrom = Sheets("Sheet3").Range("I8")
printTo = Sheets("Sheet3").Range("I9")
Set OutApp = CreateObject("Outlook.Application")
For i = printFrom To printTo
Sheets("Sheet3").Range("I5") = i
ThisWorkbook.Sheets("Sheet3").Range("A1:D33").Select
Range("A1:D33").Copy
Workbooks.Add(xlWBATWorksheet).Sheets("Sheet1").Select
Range("A1:D33").Select
ActiveWorkbook.ActiveSheet.PasteSpecial
Columns("A:D").AutoFit
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'HAM NAY CHI DC DUNG TRONG RANGE
sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True _
, CreateBackup:=False
Workbooks.Add.Close Savechanges:=False
ActiveWorkbook.Close False

Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheets("Sheet3").Range("B12")
.cc = ""
.BCC = ""
.Subject = Sheets("Sheet3").Range("B9")
.HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
"<BR>Should you have any questions, do not hestitate to contact us." & _
"<BR><BR>Thanks & regards</B><BR>" & _
"</B>"
.Attachments.Add (sFile)
.Send
End With
Set OutMail = Nothing
Next i
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox "Success"

End Sub



Mình lại dính lỗi nãy, mình có xem xét lại từ đầu đến cuối mà vẫn báo lỗi sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
Mấy anh giúp em với ạ, em không hiểu sai chổ nào cả.
Mình nghĩ rằng để không bị lẫn lộn giữa cái workbook hiện tại với workbook tạo mới thì bạn nên tạo ra 2 biến:
Mã:
Dim wbNew As Workbook, wbThis As Workbook
Với cái này thì mình viết lại cái code (viết theo mình suy nghĩ là vậy, có thể code không đúng ý đồ của bạn chỗ nào thì bạn chỉnh lại chỗ đó giúp nha...)

Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim wbNew As Workbook, wbThis As Workbook
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
       
        wbThis.Sheets("Sheet3").Range("A1:D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1:D33").PasteSpecial xlPasteValues
            .Range("A1:D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
       
        sFile = wbThis.Path & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub
 
Sub Button7_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String
Dim sPath As String
Dim i As Long
printFrom = Sheets("Sheet3").Range("I8")
printTo = Sheets("Sheet3").Range("I9")
Set OutApp = CreateObject("Outlook.Application")
For i = printFrom To printTo
Sheets("Sheet3").Range("I5") = i
ThisWorkbook.Sheets("Sheet3").Range("A1:D33").Select
Range("A1:D33").Copy
Workbooks.Add(xlWBATWorksheet).Sheets("Sheet1").Select
Range("A1:D33").Select
ActiveWorkbook.ActiveSheet.PasteSpecial
Columns("A:D").AutoFit
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'HAM NAY CHI DC DUNG TRONG RANGE
sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True _
, CreateBackup:=False
Workbooks.Add.Close Savechanges:=False
ActiveWorkbook.Close False

Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheets("Sheet3").Range("B12")
.cc = ""
.BCC = ""
.Subject = Sheets("Sheet3").Range("B9")
.HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
"<BR>Should you have any questions, do not hestitate to contact us." & _
"<BR><BR>Thanks & regards</B><BR>" & _
"</B>"
.Attachments.Add (sFile)
.Send
End With
Set OutMail = Nothing
Next i
Set OutApp = Nothing
Set OutMail = Nothing
MsgBox "Success"

End Sub



Mình lại dính lỗi nãy, mình có xem xét lại từ đầu đến cuối mà vẫn báo lỗi sFile = ActiveWorkbook.Path & "\" & "Payslip Oct 2020 - " & Sheets("Sheet3").Range("B11") & ".xlsx"
Mấy anh giúp em với ạ, em không hiểu sai chổ nào cả.
Lỗi vì các mặt cười, như dòng này
ThisWorkbook.Sheets("Sheet3").Range("A1:D33").Select

Chắc vậy, đoán đại vì nhìn thấy vậy
 
Lỗi vì các mặt cười, như dòng này
ThisWorkbook.Sheets("Sheet3").Range("A1:D33").Select

Chắc vậy, đoán đại vì nhìn thấy vậy
Đó là lỗi biến 2 hoặc 3 ký tự thành biểu tượng. Dấu hai chấm ":" và chữ "D" là biểu tượng mặt cười. Để tránh thì nên viết cách ra 1 khoảng trắng như : D, viết liền sẽ là :D


Câu lệnh sẽ là Range("A1: D33").Select
 
Để tránh thì nên viết cách ra 1 khoảng trắng như : D
Nên cho vào các thẻ [ code] chứ anh.
Vụ này em nói nhiều lắm rồi á. Ở diễn đàn chuyên môn thì cái này là luật bắt buộc, vi phạm là 'auto' xóa luôn.
------
Hỏi thăm: Anh được 'cho' về chưa ạ?
 
Đó là lỗi biến 2 hoặc 3 ký tự thành biểu tượng. Dấu hai chấm ":" và chữ "D" là biểu tượng mặt cười. Để tránh thì nên viết cách ra 1 khoảng trắng như : D, viết liền sẽ là :D
Câu lệnh sẽ là Range("A1: D33").Select
Còn nếu là code thì các bạn nên cho vào thẻ code 1601610319881.png
Mã:
để tránh trường hợp này....
 
Đó là lỗi biến 2 hoặc 3 ký tự thành biểu tượng. Dấu hai chấm ":" và chữ "D" là biểu tượng mặt cười. Để tránh thì nên viết cách ra 1 khoảng trắng như : D, viết liền sẽ là :D


Câu lệnh sẽ là Range("A1: D33").Select
Ah, ý là nhắc người hỏi nên đặt vào trong tab [ code] ... [ /code]
 
Đó là lỗi biến 2 hoặc 3 ký tự thành biểu tượng. Dấu hai chấm ":" và chữ "D" là biểu tượng mặt cười. Để tránh thì nên viết cách ra 1 khoảng trắng như : D, viết liền sẽ là :D


Câu lệnh sẽ là Range("A1: D33").Select
cảm ơn bác nhiều nhé, hi
Bài đã được tự động gộp:

Mình nghĩ rằng để không bị lẫn lộn giữa cái workbook hiện tại với workbook tạo mới thì bạn nên tạo ra 2 biến:
Mã:
Dim wbNew As Workbook, wbThis As Workbook
Với cái này thì mình viết lại cái code (viết theo mình suy nghĩ là vậy, có thể code không đúng ý đồ của bạn chỗ nào thì bạn chỉnh lại chỗ đó giúp nha...)

Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim wbNew As Workbook, wbThis As Workbook
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
      
        wbThis.Sheets("Sheet3").Range("A1:D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1:D33").PasteSpecial xlPasteValues
            .Range("A1:D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
      
        sFile = wbThis.Path & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub


Thanks bác nhé. đúng là ghi rõ ra thì dễ nhìn hơn và dễ phân biệt hơn hẳn
Bài đã được tự động gộp:

Lúc nãy em không xem các dòng code khác, giờ xem kỹ lại thì lỗi vẫn là do file hiện hành không có Sheet3.
File chứa code thì có Sheet3 nhưng file mới tạo bằng lệnh Workbooks.Add thì không có. Code trỏ đến Sheet3 (bằng SheetName) mà không xác định workbook nên mặc định trỏ đến workbook hiện hành. Khi thêm workbook mới thì workbook mới thành workbook hiện hành, code trỏ đến Sheet3 của workbook hiện hành nhưng không có -> lỗi.
Nếu muốn trỏ đến Sheet3 của workbook chứa code thì viết rõ ThisWorkbook.Sheets("Sheet3"). Ngoài ra, ActiveWorkbook.Path trong dòng lệnh đó luôn trả về.chuỗi rỗng do ActiveWorkbook là workbook chưa được save.
@Chủ topic: Nên tạo thói quen khi trỏ đến đối tượng bằng tên thì chỉ rõ đối tượng cha. Thói quen này giúp code rõ ràng hơn và hạn chế lỗi hoặc code thực thi không đúng ý đồ của người viết code. Lỗi còn biết để mà sửa chứ chạy sai mà không phát hiện được thì hậu quả khôn lường.
Cảm ơn bạn đã đóng góp ý kiến, chân thành cảm ơn nha
 
Nên cho vào các thẻ [ code] chứ anh.
Vụ này em nói nhiều lắm rồi á. Ở diễn đàn chuyên môn thì cái này là luật bắt buộc, vi phạm là 'auto' xóa luôn.
Để giải thích cái mặt cười thôi, còn vụ thẻ [ code] thì mình xài thường nhưng không biết công dụng số 2.
Thử cái coi
PHP:
Range("A1:D33").Select
Hỏi thăm: Anh được 'cho' về chưa ạ?
May quá chỉ ở 4 ngày và về rồi, ở nhà ngồi máy tính mới viết được mấy bài dài dài hay hay chứ post bằng điện thoại chán lắm.
 
Mình nghĩ rằng để không bị lẫn lộn giữa cái workbook hiện tại với workbook tạo mới thì bạn nên tạo ra 2 biến:
Mã:
Dim wbNew As Workbook, wbThis As Workbook
Với cái này thì mình viết lại cái code (viết theo mình suy nghĩ là vậy, có thể code không đúng ý đồ của bạn chỗ nào thì bạn chỉnh lại chỗ đó giúp nha...)

Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim wbNew As Workbook, wbThis As Workbook
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
      
        wbThis.Sheets("Sheet3").Range("A1:D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1:D33").PasteSpecial xlPasteValues
            .Range("A1:D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
      
        sFile = wbThis.Path & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub


Bạn ơi, cho mình hỏi mình có tạo một folder với mã :
Set fso = CreateObject("Scripting.FileSystemObject")
FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
If fso.FolderExists(FName) Then
fso.CreateFolder (FName)
End If


Và mình chỉnh sữa lệnh :sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
Nó báo lỗi : run-time error '1004' Microsoft excel cannot access the file.
Giải thích hộ mình với ạ.
Bài đã được tự động gộp:

Bạn ơi, cho mình hỏi mình có tạo một folder với mã :
Set fso = CreateObject("Scripting.FileSystemObject")
FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
If fso.FolderExists(FName) Then
fso.CreateFolder (FName)
End If


Và mình chỉnh sữa lệnh :sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
Nó báo lỗi : run-time error '1004' Microsoft excel cannot access the file.
Giải thích hộ mình với ạ.
Lỗi sai : wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
 
Bạn ơi, cho mình hỏi mình có tạo một folder với mã :
Set fso = CreateObject("Scripting.FileSystemObject")
FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
If fso.FolderExists(FName) Then
fso.CreateFolder (FName)
End If


Và mình chỉnh sữa lệnh :sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
Nó báo lỗi : run-time error '1004' Microsoft excel cannot access the file.
Giải thích hộ mình với ạ.
bạn dưa lên hết code bạn viêt lên, chứ mà nói khơi khơi mình không biết sao nữa ah...

NHẮC LẠI: nhớ khi đưa code lên thì phải đặt trong thẻ code nha (xem bài #10)
 
bạn dưa lên hết code bạn viêt lên, chứ mà nói khơi khơi mình không biết sao nữa ah...

NHẮC LẠI: nhớ khi đưa code lên thì phải đặt trong thẻ code nha (xem bài #10)
Mình có tạo một folder và muốn tạo file theo vòng lặp . lưu file vô folder đó lun.
Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim FName As String
Dim fso As Object
Dim wbNew As Workbook, wbThis As Workbook
    FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
     Const DeleteReadOnly = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FName) Then
        fso.DeleteFolder (FName), DeleteReadOnly
        fso.CreateFolder (FName)
    End If
    If Not fso.FolderExists(FName) Then
        fso.CreateFolder (FName)
    End If
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
      
        wbThis.Sheets("Sheet3").Range("A1: D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1: D33").PasteSpecial xlPasteValues
            .Range("A1: D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
      
        sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            'ActiveWorkbook.FullName
            
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub
Bài đã được tự động gộp:

bạn dưa lên hết code bạn viêt lên, chứ mà nói khơi khơi mình không biết sao nữa ah...

NHẮC LẠI: nhớ khi đưa code lên thì phải đặt trong thẻ code nha (xem bài #10)
sr bạn, mình chạy được code rùi, mà bạn ơi, có cách nào để tạo mật khẩu chạy theo bảng dữ liệu như to và from không bạn,
 
Lần chỉnh sửa cuối:
Mình có tạo một folder và muốn tạo file theo vòng lặp . lưu file vô folder đó lun.
Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim FName As String
Dim fso As Object
Dim wbNew As Workbook, wbThis As Workbook
    FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
     Const DeleteReadOnly = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FName) Then
        fso.DeleteFolder (FName), DeleteReadOnly
        fso.CreateFolder (FName)
    End If
    If Not fso.FolderExists(FName) Then
        fso.CreateFolder (FName)
    End If
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
     
        wbThis.Sheets("Sheet3").Range("A1: D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1: D33").PasteSpecial xlPasteValues
            .Range("A1: D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
     
        sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            'ActiveWorkbook.FullName
           
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub
Ngộ vậy ta? mình chạy code này vèo vèo mà? không có bị gì hết ah....
""":::":\
Bài đã được tự động gộp:

Mình có tạo một folder và muốn tạo file theo vòng lặp . lưu file vô folder đó lun.
Mã:
Sub Button7_Click()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant
Dim sFile As String, sPath As String
Dim i As Long
Dim FName As String
Dim fso As Object
Dim wbNew As Workbook, wbThis As Workbook
    FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
     Const DeleteReadOnly = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FName) Then
        fso.DeleteFolder (FName), DeleteReadOnly
        fso.CreateFolder (FName)
    End If
    If Not fso.FolderExists(FName) Then
        fso.CreateFolder (FName)
    End If
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("Sheet3").Range("I8")
    printTo = wbThis.Sheets("Sheet3").Range("I9")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("Sheet3").Range("I5") = i
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
     
        wbThis.Sheets("Sheet3").Range("A1: D33").Copy
        With wbNew.Sheets("Sheet1")
            .Range("A1: D33").PasteSpecial xlPasteValues
            .Range("A1: D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
        End With
        Application.CutCopyMode = False
     
        sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11") & ".xlsx"
        wbNew.SaveAs Filename:=sFile, FileFormat:=51, WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
        wbNew.Close False
        Set wbNew = Nothing
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("Sheet3").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("Sheet3").Range("B9")
            .HTMLBody = " Dear " & Sheets("Sheet3").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip of October 2020. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            .Attachments.Add (sFile)
            'ActiveWorkbook.FullName
           
            .Send
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Success"

End Sub
Bài đã được tự động gộp:


sr bạn, mình chạy được code rùi, mà bạn ơi, có cách nào để tạo mật khẩu chạy theo bảng dữ liệu như to và from không bạn,
xin lỗi mình hổng hiểu ý bạn là gì???? có thể nói rõ hơn đươc không?
 
Mình có tạo một folder và muốn tạo file theo vòng lặp . lưu file vô folder đó lun.
Mã:
    Set wbThis = ThisWorkbook

        Set wbNew = Workbooks.Add(xlWBATWorksheet)
Đặt tên biến nếu viết tắt từ tiếng Anh thì phải theo văn phạm tiếng Anh, ThisWb (this workbook) và NewWb (new workbook) chứ sao lại ngược thế kia
 
Ngộ vậy ta? mình chạy code này vèo vèo mà? không có bị gì hết ah....
""":::":\
Bài đã được tự động gộp:


xin lỗi mình hổng hiểu ý bạn là gì???? có thể nói rõ hơn đươc không?
ý là mình có một bảng dữ liệu trong đó mình có cột dữ liệu chứa các mật khẩu, và mình muốn lấy mk để gán cho từng file , mình đã thử tuy nhiên chỉ hỉu được một mk dòng thui
Bài đã được tự động gộp:

Đặt tên biến nếu viết tắt từ tiếng Anh thì phải theo văn phạm tiếng Anh, ThisWb (this workbook) và NewWb (new workbook) chứ sao lại ngược thế kia
À sr bạn, mình sẽ sữa lại code.
 
Đặt tên biến nếu viết tắt từ tiếng Anh thì phải theo văn phạm tiếng Anh, ThisWb (this workbook) và NewWb (new workbook) chứ sao lại ngược thế kia
Dạ, cái này là của em chứ không phải của bạn @duongvanminh33 ạ.
tại em theo qui tắc riếng của em là tiếp đầu ngữ của biến là kiểu biến và tiếp theo là cái tên thể hiện.
ví dụ: wbThis có nghĩa là: wb=> kiểu là Workbook và This có nghĩa là ThisWorkBook
Bài đã được tự động gộp:

ý là mình có một bảng dữ liệu trong đó mình có cột dữ liệu chứa các mật khẩu, và mình muốn lấy mk để gán cho từng file , mình đã thử tuy nhiên chỉ hỉu được một mk dòng thui
Mình thấy bạn đã làm việc thay đổi giá trị tại Cell I5 của Sheet3 bằng câu lệnh "wbThis.Sheets("Sheet3").Range("I5") = i" mà???
thế thì cái mật khẩu cho từng hàng dữ liệu thì cũng giống y chang các dữ liệu được điền vào khi thay đổi giá trị tại Cell I5 thôi!!!
 
Lần chỉnh sửa cuối:
Dạ, cái này là của em chứ không phải của bạn @duongvanminh33 ạ.
tại em theo qui tắc riếng của em là tiếp đầu ngữ của biến là kiểu biến và tiếp theo là cái tên thể hiện.
ví dụ: wbThis có nghĩa là: wb=> kiểu là Workbook và This có nghĩa là ThisWorkBook
Bài đã được tự động gộp:


Mình thấy bạn đã làm việc thay đổi giá trị tại Cell I5 của Sheet3 bằng câu lệnh "wbThis.Sheets("Sheet3").Range("I5") = i" mà???
thế thì cái mật khẩu cho từng hàng dữ liệu thì cũng giống y chang các dữ liệu được điền vào khi thay đổi giá trị tại Cell I5 thôi!!!
thanks bạn nhìu nhé, có mỗi cái tạo mk tại ô vlookup range("") rùi nhét vô vòng for mail là chạy được rùi, dò cả buổi mới được, chân thành cảm ơn bạn
 
Dạ, cái này là của em chứ không phải của bạn @duongvanminh33 ạ.
tại em theo qui tắc riếng của em là tiếp đầu ngữ của biến là kiểu biến và tiếp theo là cái tên thể hiện.
ví dụ: wbThis có nghĩa là: wb=> kiểu là Workbook và This có nghĩa là ThisWorkBook
Bài đã được tự động gộp:


Mình thấy bạn đã làm việc thay đổi giá trị tại Cell I5 của Sheet3 bằng câu lệnh "wbThis.Sheets("Sheet3").Range("I5") = i" mà???
thế thì cái mật khẩu cho từng hàng dữ liệu thì cũng giống y chang các dữ liệu được điền vào khi thay đổi giá trị tại Cell I5 thôi!!!

"Object Doesn't Support this Method"
Bạn giúp mình lỗi này với, chạy dữ liệu ít thì không sao, khi gửi khoảng trên 35 người là sẽ xuất hiện lỗi này.
 
bạn chụp lại cái vị trí lỗi cho mình xem thử

Chỉ hiện một bảng thông báo thôi bạn, bấm chọn ok thì sẽ về lại đoạn copy sheet mà chưa được save lại.
Bài đã được tự động gộp:

bạn chụp lại cái vị trí lỗi cho mình xem thử
Chỉ hiện một bảng thông báo thôi bạn, bấm chọn ok thì sẽ về lại đoạn copy sheet mà chưa được save lại.
bạn chụp lại cái vị trí lỗi cho mình xem thử


Có nghĩa là sẽ có một bảng thông báo lỗi "Object Doesn't Support this Method", khi bấm ok thì sẽ về lại bình thường, ko có báo lỗi dòng nào code cả bạn à, tuy nhiên mình có để ý là nó lỗi chạy thường là tới đoạn copy range của sheet thiswb xong paste vô sheet là ngưng. chưa save được. Chạy khoảng 10 -20 người thì ổn, tuy nhiên chạy trên 35 người sẽ xuất hiện lỗi đó. Bạn giúp mình với nhé.
 
Lần chỉnh sửa cuối:
Chỉ hiện một bảng thông báo thôi bạn, bấm chọn ok thì sẽ về lại đoạn copy sheet mà chưa được save lại.

Có nghĩa là sẽ có một bảng thông báo lỗi "Object Doesn't Support this Method", khi bấm ok thì sẽ về lại bình thường, ko có báo lỗi dòng nào code cả bạn à, tuy nhiên mình có để ý là nó lỗi chạy thường là tới đoạn copy range của sheet thiswb xong paste vô sheet là ngưng. chưa save được. Chạy khoảng 10 -20 người thì ổn, tuy nhiên chạy trên 35 người sẽ xuất hiện lỗi đó. Bạn giúp mình với nhé.
Ngộ ta? thường thì nó chạy hay không chạy được code thôi nếu như Không bị lỗi dữ liệu.
Chú ý dòng này:
Mã:
sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11").Value & ".xlsx"
Tên file phải không có mấy cái ký tự đặc biệt ah....
 
Ngộ ta? thường thì nó chạy hay không chạy được code thôi nếu như Không bị lỗi dữ liệu.
Chú ý dòng này:
Mã:
sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11").Value & ".xlsx"
Tên file phải không có mấy cái ký tự đặc biệt ah....


Mã:
Sub Button7_Click2()
Dim OutApp As Object, OutMail As Object
Dim printFrom As Variant, printTo As Variant, mk As Long
Dim sFile As String, sPath As String
Dim i As Long
Dim j As Long
Dim FName As String
Dim fso As Object
Dim wbNew As Workbook, wbThis As Workbook
Dim Answer As Integer

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo lbFinally
Answer = MsgBox("Do you want to save file and send mail?", vbQuestion + vbYesNo)
 
  If Answer = vbYes Then
    'MsgBox "You Choose Yes"
    FName = ThisWorkbook.Path & "\PhieuLuong - " & Format(Now, "MMM DD YY")
     Const DeleteReadOnly = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(FName) Then
        fso.DeleteFolder (FName), DeleteReadOnly
        fso.CreateFolder (FName)
    End If
    If Not fso.FolderExists(FName) Then
        fso.CreateFolder (FName)
    End If
    Set wbThis = ThisWorkbook
    printFrom = wbThis.Sheets("PAYSLIP").Range("I8")
    printTo = wbThis.Sheets("PAYSLIP").Range("I9")
   ' mk = wbThis.Sheets("PAYSLIP").Range("I14")
    Set OutApp = CreateObject("Outlook.Application")
    For i = printFrom To printTo
        wbThis.Sheets("PAYSLIP").Range("I5") = i
        mk = wbThis.Sheets("PAYSLIP").Range("I14")
        
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
      
        wbThis.Sheets("PAYSLIP").Range("A1:D33").Copy
        With wbNew.Sheets(1)
            .Range("A1:D33").PasteSpecial xlPasteValues
            .Range("A1:D33").PasteSpecial xlPasteFormats
            .Columns("A:D").AutoFit
            
        End With
        Application.CutCopyMode = False
        
        sFile = FName & "\" & wbThis.Sheets("PAYSLIP").Range("A9") & " - " & wbThis.Sheets("PAYSLIP").Range("B13") & ".xlsx"
        
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = wbThis.Sheets("PAYSLIP").Range("B12")
            .cc = ""
            .BCC = ""
            .Subject = wbThis.Sheets("PAYSLIP").Range("A9")
            .HTMLBody = " Dear " & wbThis.Sheets("PAYSLIP").Range("B11") & "</B> <BR><BR> Kindly find attachment payslip. <BR>" & _
            "<BR>Should you have any questions, do not hestitate to contact us." & _
            "<BR><BR>Thanks & regards</B><BR>" & _
            "</B>"
            wbNew.SaveAs Filename:=sFile, FileFormat:=51, Password:=mk, ReadOnlyRecommended:=True, CreateBackup:=False
             wbNew.Close False
             Set wbNew = Nothing
            .Attachments.Add (sFile)
            
            .send
            
        End With
        Set OutMail = Nothing
    Next i
    Set OutApp = Nothing
    Set OutMail = Nothing
    MsgBox "Mail send successfully"
    Else
    MsgBox "No Choose """
  End If
lbFinally:
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationSemiautomatic
    
    If Err <> 0 Then
        MsgBox Err.Description, vbCritical
    End If


End Sub

MÌNH TEST THÌ VẪN BỊ, BẠN KT GIÚP VỚI, HAY MINH THIẾU GIAO DIỆN REFERENCES -VBAPROJECT KHÔNG NHỈ ?? MÌNH MỚI TẬP TÀNH VBA NÊN KHÔNG RÀNH LẮM
 
Ngộ ta? thường thì nó chạy hay không chạy được code thôi nếu như Không bị lỗi dữ liệu.
Chú ý dòng này:
Mã:
sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11").Value & ".xlsx"
Tên file phải không có mấy cái ký tự đặc biệt ah....

LÚC BỊ LÚC KHÔNG BỊ, KHÓ HIỂU GHÊ
 
Ngộ ta? thường thì nó chạy hay không chạy được code thôi nếu như Không bị lỗi dữ liệu.
Chú ý dòng này:
Mã:
sFile = FName & "\" & "Payslip Oct 2020 - " & wbThis.Sheets("Sheet3").Range("B11").Value & ".xlsx"
Tên file phải không có mấy cái ký tự đặc biệt ah....


Mình đã thử không sử dụng ký tự đặc biệt rồi, tuy nhiên vẫn báo lỗi đó. Chọn gửi ít thì gửi được, cứ gửi trên 35 (minh gửi full 98 người) là sẽ bị báo lỗi đó.
 
Mình đã thử không sử dụng ký tự đặc biệt rồi, tuy nhiên vẫn báo lỗi đó. Chọn gửi ít thì gửi được, cứ gửi trên 35 (minh gửi full 98 người) là sẽ bị báo lỗi đó.
Không rõ file attach có nặng không, nên cho thời gian đợi cho outlook
Không có không xử lý kip thì có thể dễ xảy ra lỗi - vì quá tải
 
Cũng vậy nên cho 10 lần gửi nghỉ 1 thời gian giờ đợi
Vì xử lý tuần tự mà, cứ gọi hoài thằng ngoài nó nặng, nó phản ứng thôi
Éc. của mình mới test mẫu 98 người thôi, thêm mấy trăm người chắc chết mất . Mình thấy có mấy bài của các bạn khác, có người gửi đến mấy trăm cơ.
Bài đã được tự động gộp:

Không rõ file attach có nặng không, nên cho thời gian đợi cho outlook
Không có không xử lý kip thì có thể dễ xảy ra lỗi - vì quá tải

À thế cho mình hỏi chút, nếu code trên của mình, giờ làm thế nào để kéo dài thời gian xử lý ra được không ạ, vd như cho gửi tới 30 người và sẽ có khoàng tgian nghỉ 10s và tiếp tục xử lý không.
 
Éc. của mình mới test mẫu 98 người thôi, thêm mấy trăm người chắc chết mất . Mình thấy có mấy bài của các bạn khác, có người gửi đến mấy trăm cơ.
Bài đã được tự động gộp:



À thế cho mình hỏi chút, nếu code trên của mình, giờ làm thế nào để kéo dài thời gian xử lý ra được không ạ, vd như cho gửi tới 30 người và sẽ có khoàng tgian nghỉ 10s và tiếp tục xử lý không.
Thì bạn lấy bài người ta (bạn khác) tham khảo

Còn muốn dừng thì tìm kiêm với từ khóa Sleep, hay wait
 
"Object Doesn't Support this Method"
Bạn giúp mình lỗi này với, chạy dữ liệu ít thì không sao, khi gửi khoảng trên 35 người là sẽ xuất hiện lỗi này.
Dịch theo thông báo thì lỗi này có nghĩa là "đối tượng không hỗ trợ phương thức này", có nghĩa như kiểu thiswordbook.ahihi thì sẽ bị lỗi, sửa hết tên các thành viên cho chuẩn, như "CC" chứ không phải cc, ".Send" chứ không phải là ".send", những cũng không chắc nữa, trong file của bạn còn có các code khác phụ trợ chạy song song, hay cac add in?
 
Dịch theo thông báo thì lỗi này có nghĩa là "đối tượng không hỗ trợ phương thức này", có nghĩa như kiểu thiswordbook.ahihi thì sẽ bị lỗi, sửa hết tên các thành viên cho chuẩn, như "CC" chứ không phải cc, ".Send" chứ không phải là ".send", những cũng không chắc nữa, trong file của bạn còn có các code khác phụ trợ chạy song song, hay cac add in?

Tất cả toàn code cả, không có add in gì bạn ơi.
 

Ý mình là mình muốn khi đang chạy send thì sẽ có các thông tin như tên , mã số NV chạy kèm theo(hiển thị trên một thanh button ). Kiểu chạy nhấp nháy dữ liệu được chỉ định ở trên một button . Khi dừng nó đâu nó sẽ báo là chạy tới đó. Như chơi game quay vật phẩm thì sẽ có hiển thị vòng quay qua các vật phẩm đó trước khi tới vật phẩm trúng thường. Kiểu kiểu thế á.
 

Bài viết mới nhất

Back
Top Bottom