Question

在运行此代码时，出现运行时错误1004，“应用程序定义的对象定义的错误”。该错误显示在第一个函数的以“ NumRows = Worksheets（“ Data”）“开头的行上。有人可以检查一下这段代码，然后让我知道这里出了什么问题。我是VBA宏的新手，但知识有限。

Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String

Dim x As Integer
      Application.ScreenUpdating = False
      NumRows = Worksheets("Data").Range("A5", Range("A5").End(xlDown)).Rows.Count  ' Set numrows = number of rows of data.
      Worksheets("Data").Range("A5").Select ' Select first record.

      For x = 1 To NumRows  ' Establish "For" loop to loop "numrows" number of times.

        eID = Worksheets("Data").Range("A" & x + 4).Value
        eName = Worksheets("Data").Range("B" & x + 4).Value
        eEmail = Worksheets("Data").Range("C" & x + 4).Value
        supportGroup = Worksheets("Data").Range("F" & x + 4).Value
        managerEmail = Worksheets("Data").Range("G" & x + 4).Value
        acName = Worksheets("Data").Range("I" & x + 4).Value


        'Prepare table to be sent locally.
        Worksheets("Data").Range("AA5").Value = eID
        Worksheets("Data").Range("AB5").Value = eName
        Worksheets("Data").Range("AC5").Value = eEmail
        Worksheets("Data").Range("AF5").Value = supportGroup

        managerEmail = managerEmail + ";" + Worksheets("Data").Range("AA1").Value

        'Call Emails function.
        Call Emails(acName, eEmail, managerEmail)

         ActiveCell.Offset(1, 0).Select
      Next

      Application.ScreenUpdating = True
End Sub

Public Sub Emails(x As String, y As String, z As String)

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Dim a As String
Dim b As String
Dim c As String

a = y
b = z
c = x

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
    .To = a
    .CC = b
    .BCC = ""
    .Subject = Worksheets("MF").Range("A1") & c
    .Body = ""
    .display

    Set xInspect = newEmail.getInspector
    Set pageEditor = xInspect.WordEditor

    Worksheets("MF").Range("A9").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A3").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("Data").Range("AA4:AF5").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A5").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

    Worksheets("MF").Range("A7").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)


    .send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing

End Sub

Answer 1

要么您的工作表必须处于活动状态，要么您必须像这样解决范围：

NumRows = Worksheets("Data").Range("A5", Worksheets("Data").Range("A5").End(xlDown)).Rows.Count

Answer 2

我已经对您的代码进行了一些更正，并且最终可以正常工作。请尝试这个。主要是与正确设置工作簿和工作表引用有关，否则您的代码似乎还可以：

Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim x As Integer

    Set ws1 = ThisWorkbook.Worksheets("Data") ' Set workbook & worksheet reference 
    Set ws2 = ThisWorkbook.Worksheets("MF")  '' Set workbook & worksheet reference 
    NumRows = ws1.Range("A5", Range("A5").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
     ws1.Range("A5").Select ' Select first record.

      For x = 1 To NumRows  ' Establish "For" loop to loop "numrows" number of times.

        eID = ws1.Range("A" & x + 4).Value
        eName = ws1.Range("B" & x + 4).Value
        eEmail = ws1.Range("C" & x + 4).Value
        supportGroup = ws1.Range("F" & x + 4).Value
        managerEmail = ws1.Range("G" & x + 4).Value
        acName = ws1.Range("I" & x + 4).Value


        'Prepare table to be sent locally.
    With ws1
        .Range("AA5").Value = eID
        .Range("AB5").Value = eName
        .Range("AC5").Value = eEmail
        .Range("AF5").Value = supportGroup

        managerEmail = managerEmail + ";" + ws1.Range("AA1").Value

        'Call Emails function.
        Call Emails(acName, eEmail, managerEmail)

         ActiveCell.Offset(1, 0).Select

    End With
      Next
      Application.ScreenUpdating = True
End Sub

Public Sub Emails(x As String, y As String, z As String)

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Dim a As String
Dim b As String
Dim c As String
Dim str As String
With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

a = y
b = z
c = x

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
Set ws2 = ThisWorkbook.Worksheets("MF")
str = ws2.Range("A1").Value & c

With newEmail
    .To = a
    .CC = b
    .BCC = ""
    .Subject = str
    .Body = ""
    .Display

    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor

   Set ws1 = ThisWorkbook.Worksheets("Data")

    ws2.Range("A9").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)

   ws2.Range("A3").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

   ws1.Range("AA4:AF5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A5").Copy
    pageEditor.Application.Selection.Paste xlValuesAndFormat (wdFormatPlainText)

    ws2.Range("A7").Copy
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)


    .Send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing
With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

无法发送电子邮件，运行时错误1004

2 个答案: