0

由于某种原因，它不会转到范围内的下一个单元格来检查值。

分解将要发生的事情

子调用 Modules1.Getdata

这会检查每一行的通知标签（“真/假”）。如果为真，它会获取 CompanyNumber 调用 Module3.Check

Moduel3.Check 使用 CompanyNumber 检查 Samevalue 的另一个工作表/范围（转到 Module1.Getdata 中的下一个迭代） 如果下一个单元格为空，请输入公司编号等。

希望这是有道理的。

子

  Sub Workbook_open()

  Call Module1.GetData

  End Sub

Module1.GetData

  Public EmailAddress As String
  Public CompanyNumber As String
  Public Name As String
  Public Comp As String
  Public ID As Integer


  Function GetData()

  Dim LastRow As String
  Dim rng As Range


  Worksheets("DDregister").Activate
  Range("K2").Select


  LastRow = Cells(Rows.Count, "K").End(xlUp).Row

  For Each rng In Range("K2:K" + LastRow)

  If Not rng.Value = vbNullString Then
      Worksheets("DDregister").Activate
      Range("K2").Select

      Select Case rng.Value
        Case 1
            Case Is = "True"
            rng.Select

                Let EmailAddress = ActiveCell.Offset(0, -5).Value
                Let CompanyNumber = ActiveCell.Offset(0, -9).Value
                Let Name = ActiveCell.Offset(0, -8).Value
                Let Comp = ActiveCell.Offset(0, -7).Value
                ID = ActiveCell.Offset(0, -10).Value


                Call Module3.Check(EmailAddress, CompanyNumber, Name, Comp)
        Case 2
            Case Is = "False"
     End Select

ElseIf rng.Value = vbNullString Then
    ThisWorkbook.Save
    Application.DisplayAlerts = True
    'ThisWorkbook.Close
End If
Next

End Function

Module3.检查

Function Check(EmailAddress As String, CompanyNumber As String, Name As String, Comp As String)

Dim rngCheck As Range
Dim LastRowCheck As String
Dim NewRange As Range

Worksheets("Check").Activate
ActiveSheet.Range("B2").Select

LastRowCheck = Cells(Rows.Count, "B").End(xlDown).Row

For Each rngCheck In Range("B2:B" + LastRowCheck)

   Select Case rngCheck.Value
    Case 1
        Case Is = CompanyNumber
        'Go to next iteration
    Case 2
        Case Is = vbNullString
            ActiveCell.Value = CompanyNumber
            ActiveCell.Offset(0, 1).Value = "True"
            ActiveCell.Offset(0, -1).Value = ID
            Call Module2.Email(EmailAddress, CompanyNumber, Name, Comp)

Next

End Function

Module2.电子邮件

Function Email(EmailAddress As String, CompanyNumber As String, Name As String, Comp As String)

Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Subject " & (Comp)
objMessage.From = "EmailAddress@Address.com"
objMessage.Cc = "EmailAddress@Address.com"
objMessage.To = (EmailAddress)
'MsgBox (EmailAddress)
objMessage.TextBody = "Stuff"

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "x.x.x.x"

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

objMessage.Configuration.Fields.Update

objMessage.Send

End Function
4

3 回答 3

0

我自己想出了一种方法，我真的很感激一些反馈，因为你可能已经猜到我是编码新手，哈哈

  Sub GetData()
Dim LastRow As String
Dim rng As Range
Dim EmailAddress As String
Dim CompanyNumber As String
Dim Name As String
Dim Comp As String
Dim ID As Integer
Dim rngCheck As Range
Dim LastRowCheck As String
Dim TodayDate As Date




TodayDate = Date
Worksheets("DDregister").Activate
Range("K2").Select


LastRow = Cells(Rows.Count, "K").End(xlUp).Row

For Each rng In Range("K2:K" + LastRow)
    Worksheets("DDregister").Activate
  Select Case rng.Value
      Case "True"

            rng.Select
            EmailAddress = ActiveCell.Offset(0, -5).Value
            CompanyNumber = ActiveCell.Offset(0, -9).Value
            Name = ActiveCell.Offset(0, -8).Value
            Comp = ActiveCell.Offset(0, -7).Value
            ID = ActiveCell.Offset(0, -10).Value

            Worksheets("Check").Activate
            Range("B2").Select

            LastRowCheck = Cells(Rows.Count, "B").End(xlUp).Row

            For Each rngCheck In Range("B2:B" & LastRowCheck)
                Select Case True

                Case ActiveCell.Value = CompanyNumber
                    ActiveCell.Offset(1, 0).Select
                    Exit For

               End Select

                If Not IsEmpty(ActiveCell.Value) Then
                    ActiveCell.Offset(1, 0).Select
                    ActiveCell.Select
                End If

                If ActiveCell.Value = "" Then
                    ActiveCell.Value = CompanyNumber
                    ActiveCell.Offset(0, 1).Value = "True"
                    ActiveCell.Offset(0, -1).Value = ID
                    ActiveCell.Offset(0, 2).Value = TodayDate
                    Call Email(EmailAddress, CompanyNumber, Name, Comp)

                 End If
            Next rngCheck

      Case "False"
      Case vbNullString
            Call Module2.MsgPopup

            'CloseBookMsgBox = MsgBox("Do you want to Close the WorkBook", vbYesNo, "WhatsThis")
            '
            If Module2.MsgPopup = vbYes Then
                ThisWorkbook.Save
                ThisWorkbook.Close
            '
            ElseIf Module2.MsgPopup = vbNo Then
                Cancel = "True"
                MsgBox "Please make sure you save changes manually and close the work book!"
            End If

            If Cancel = "True" Then Exit Sub



 End Select
 Next rng
 End Sub

 Sub Email(EmailAddress As String, CompanyNumber As String, Name As String, Comp As String)

 Set objMessage = CreateObject("CDO.Message")
 objMessage.Subject = "stuff" & (Comp)
 objMessage.From = "emailaddress"
 objMessage.Cc = "emailaddress"
 objMessage.to = EmailAddress

 objMessage.TextBody = "stuff"

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "x.x.x.x"

    objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

objMessage.Configuration.Fields.Update

objMessage.Send

End Sub

由于我将运行计划任务以在打开时执行此操作，因此我需要添加一个延迟的 msgbox，因为我们还需要手动更改文档。因此，如果达到超时期限，我需要默认为“否”。我在下面的函数中尝试这个（它的工作atm）

 Set objWshell = CreateObject(“WScript.Shell”)

这部分的任何帮助都会很棒，目前告诉我“这一行需要对象^。即使它是“设置”

Public Function MsgPopup(Optional Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional SecondsToWait As Long = 0) As VbMsgBoxResult

Dim objWshell As Object

Set objWshell = CreateObject(“WScript.Shell”)

MsgPopup = objWshell.Popup(Prompt, 20, "Do you want to Close the WorkBook", vbYesNo)

Set objWshell = Nothing

End Function
于 2013-10-01T13:07:03.887 回答
0

这与您的需求相差多远？这一切都进入一个标准模块，完全替代您的代码：

Option Explicit

Public Enum DataRef
    ID = 1
    CompanyNumber = 2
    Name = 3
    Comp = 4
    Email = 6
End Enum


Sub test()

Dim vData, vSubData
Dim lngRow As Long

With Worksheets("DDregister")
    vData = .Range("A2:K" & .Cells(.Rows.Count, "K").End(xlUp).Row)
End With

If Len(vData(1, 11)) > 0 Then
    For lngRow = LBound(vData) To UBound(vData)
        If vData(lngRow, 11) = "True" Then
            With Worksheets("Check").Columns(2)
                If .Find(vData(lngRow, DataRef.CompanyNumber), , xlValues) Is Nothing Then
                    vSubData = Array(vData(lngRow, DataRef.ID), vData(lngRow, DataRef.CompanyNumber), "True")
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, -1).Resize(, 3).Value = vSubData
                    SendEmail vData(lngRow, DataRef.Email), vData(lngRow, DataRef.Comp)
                End If
            End With
        End If
    Next lngRow
Else
    ThisWorkbook.Save
End If



End Sub

Sub SendEmail(ByVal EmailAddress As String, ByVal Comp As String)

    Dim objMessage As Object

    Set objMessage = CreateObject("CDO.Message")
    With objMessage
        .Subject = "Subject " & Comp
        .From = "EmailAddress@Address.com"
        .Cc = "EmailAddress@Address.com"
        .To = EmailAddress
        .TextBody = "Stuff"

        .Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

        .Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "x.x.x.x"

        .Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

        .Configuration.Fields.Update
        .Send
    End With

End Sub
于 2013-10-01T09:20:28.203 回答
0

假设“True”和“False”实际上是字符串而不是布尔值，我认为 GetData 应该看起来更像以下内容：

Sub GetData()
    Dim LastRow As String
    Dim rng As Range
    Dim EmailAddress As String
    Dim CompanyNumber As String
    Dim Name As String
    Dim Comp As String
    Dim ID As Integer

    Worksheets("DDregister").Activate
    Range("K2").Select


    Lastrow = Worksheets("DDregister").Cells(Rows.Count, "K").End(xlUp).Row

    For Each rng In Range("K2:K" & LastRow)
      Select Case rng.value
          Case "True"
              EmailAddress = Worksheets("DDregister").Cells(rng.Row,"F").Value
              CompanyNumber = Worksheets("DDregister").Cells(rng.Row,"B").Value
              Name = Worksheets("DDregister").Cells(rng.Row,"C").Value
              Comp = Worksheets("DDregister").Cells(rng.Row,"D").Value
              ID = Worksheets("DDregister").Cells(rng.Row,"A").Value
              Call Module3.Check(EmailAddress, CompanyNumber, Name, Comp)
          Case "False"
          Case vbNullString
              ThisWorkbook.Save
              Application.DisplayAlerts = True
              'ThisWorkbook.Close
     End Select
   Next rng
End Sub

这也是一个子程序，因为它不返回任何内容，为什么要将所有这些例程放在不同的模块中？由于您正在传递值，因此没有理由通过将它们列在子之外来使它们成为全局

PS 我没有修复你的其他 SELECT CASE 语句，但它有类似的问题。SELECT CASE 语法您使用它的方式如下

 SELECT CASE [expression]
      CASE [condition]
      CASE [condition]
      CASE ELSE
 END SELECT
于 2013-09-30T15:25:43.277 回答