循环迭代不会按预期工作

时间：2013-09-30 14:29:53

标签： excel vba excel-vba

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

分解将要发生的事情

Sub调用Modules1.Getdata

这将检查每一行的通知标记（“True / False”）。如果为true，则抓取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.Check 

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.Email 

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

3 个答案:

答案 0 :(得分：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

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

之外来使它们全局化

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

 SELECT CASE [expression]
      CASE [condition]
      CASE [condition]
      CASE ELSE
 END SELECT

答案 1 :(得分：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

答案 2 :(得分：0)

我已经找到了一种自己做的方法，我真的很感激一些反馈，因为你可能已经猜到了我的新编码lol 

  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
相关问题
最新问题