VBA电子邮件问题

我正在尝试设置电子邮件VBA以读取特定单元格引用中的信息。我知道我可以把工作表的名称，这将工作的方式，但我需要的文件能够非常可调整。这将在我们所有的网站使用，他们都有很大的不同，所以我需要能够使任何人调整文件

代码需要读取工作表“跟踪器”单元格“C6”中的信息，如果它与数字匹配，则将多张工作表复制到临时文件中，该临时文件将创建为通过电子邮件发送

要复制的范围是C8:K8

我目前拥有以下blow代码：

    Option Explicit
    Sub Email()
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim Sourcewb As Workbook
        Dim Destwb As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim OutApp As Object
        Dim OutMail As Object
        Dim sh As Worksheet
        Dim TheActiveWindow As Window
        Dim TempWindow As Window
        Dim SendTo As String
        Dim SendCC As String
        Dim SendBCC As String
        Dim SendBody As String
        Dim Subject As String

    'Revert Main Sheet Name
    If Not ActiveSheet.Name = Sheets("Tracker").Range("B7").Value Then
    ActiveSheet.Name = Sheets("Tracker").Range("B7").Value
    End If
    'Main Code
    Application.EnableEvents = False
    Dim Answer As String
    Answer = InputBoxDK("What's the password?", "Password")
        If Answer = Sheets("Passwords").Range("D8").Value Then
    'Stop Updating Screen
        Application.ScreenUpdating = False

        If Sheets(Sheets("Tracker").Range("L7").Value).Range("D6") > 0 Then
        SendTo = Sheets(Sheets("Tracker").Range("L7").Value).Range("D6")
        End If
            If Sheets(Sheets("Tracker").Range("L7").Value).Range("D9") > 0 Then
            SendCC = Sheets(Sheets("Tracker").Range("L7").Value).Range("D9")
            End If
                If Sheets(Sheets("Tracker").Range("L7").Value).Range("D12") > 0 Then
                SendBCC = Sheets(Sheets("Tracker").Range("L7").Value).Range("D12")
                End If
                    If Sheets(Sheets("Tracker").Range("L7").Value).Range("H5") > 0 Then
                    SendBody = Sheets(Sheets("Tracker").Range("L7").Value).Range("H5")
                    End If
                        If Sheets(Sheets("Tracker").Range("L7").Value).Range("D17") > 0 Then
                        Subject = Sheets(Sheets("Tracker").Range("L7").Value).Range("D17")
                        End If

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        'Checks Range to see if they have values - email whatever has value
    If Sheets("Tracker").Range("C8").Value > 0 Then
    Sheets(Sheets("Tracker").Range("C8").Value).Visible = True
        If Sheets("Tracker").Range("D8").Value > 0 Then
        Sheets(Sheets("Tracker").Range("D8").Value).Visible = True
            If Sheets("Tracker").Range("E8").Value > 0 Then
            Sheets(Sheets("Tracker").Range("E8").Value).Visible = True
                If Sheets("Tracker").Range("F8").Value > 0 Then
                Sheets(Sheets("Tracker").Range("F8").Value).Visible = True
                    If Sheets("Tracker").Range("G8").Value > 0 Then
                    Sheets(Sheets("Tracker").Range("G8").Value).Visible = True
                        If Sheets("Tracker").Range("H8").Value > 0 Then
                        Sheets(Sheets("Tracker").Range("H8").Value).Visible = True
                            If Sheets("Tracker").Range("I8").Value > 0 Then
                            Sheets(Sheets("Tracker").Range("I8").Value).Visible = True
                                If Sheets("Tracker").Range("J8").Value > 0 Then
                                Sheets(Sheets("Tracker").Range("K8").Value).Visible = True
                                    If Sheets("Tracker").Range("K8").Value > 0 Then
                                    Sheets(Sheets("Tracker").Range("K8").Value).Visible = True
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If


        Set Sourcewb = ActiveWorkbook

        'Copy the sheets to a new workbook
        With Sourcewb
            Set TheActiveWindow = ActiveWindow
            Set TempWindow = .NewWindow


'THIS IS WHERE I NEED HELP    
    If Sheets("Tracker").Range("C6").Value = 9 Then
    Else: GoTo Skip1
    Skip1:
        If Sheets("Tracker").Range("C6").Value = 8 Then
        Sheets(Sheets("Tracker").Range("C8").Value).Copy
        Else: GoTo Skip2
    Skip2:
            If Sheets("Tracker").Range("C6").Value = 7 Then
            Sheets(Sheets("Tracker").Range("C8" & "D8").Value).Copy
            End If
        End If
    End If


        End With

        'Close temporary Window
        TempWindow.Close

        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            If Val(Application.Version) < 12 Then
                FileExtStr = ".xls": FileFormatNum = -4143
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End With

        'Save the new workbook/Mail it/Delete it
        TempFilePath = Environ$("temp") & "\"
        TempFileName = Sourcewb.Name & " " & Format(Now, "Mmmm")

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .To = SendTo
                .CC = SendCC
                .BCC = SendBCC
                .Subject = Subject
                .Body = SendBody
                .Attachments.Add Destwb.FullName
                .Display
            End With
            On Error GoTo 0
            .Close savechanges:=False
        End With

            'Delete data to create template for next month

            '''''''''''''''''''''Sheets("Helmet1").Range("I8:P1008").Value = ""


        Else: MsgBox "Wrong password", vbCritical + vbOKCancel, "Incorrect Password"
        GoTo Exit1
        End If

        'Delete the file you have send
        Kill TempFilePath & TempFileName & FileExtStr

        Set OutMail = Nothing
        Set OutApp = Nothing

       '''''''''''''''''''' Sheets("Main Page").Visible = True
       ''''''''''''''''' Sheets("Climbing Equipment").Visible = False
       ''''''''''''' Sheets("Helmet1").Visible = False

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
    Exit1:
        End With
    End Sub

---

这不是一个“这样做，一切都会好起来”的答案，因为我不知道你想做什么。相反，它列出了所有我认为是错误的东西，我希望这些东西能让你更接近你所寻找的代码

Option Explicit
Sub CreateNewWorkbook()

  Dim ColWtcCrnt As Long
  Dim WbkDestName As String
  Dim WshtCrnt As Worksheet
  Dim WshtCrntName As Variant
  Dim WshtParam As Worksheet
  Dim WshtToCopy As Variant
  Dim WbkDest As Workbook
  Dim WbkThis As Workbook

  Application.ScreenUpdating = False

  Set WbkThis = ThisWorkbook

  Set WshtParam = Worksheets(WbkThis.Worksheets("Tracker").Range("B7").Value)

  ' Load range into a variant as a 2D array
  WshtToCopy = WshtParam.Range("C8:K8")

  Set WbkDest = Workbooks.Add

  With WbkDest

    For ColWtcCrnt = 1 To UBound(WshtToCopy, 2)
      WshtCrntName = WshtToCopy(1, ColWtcCrnt)
      If WshtCrntName <> "" Then
        Set WshtCrnt = WbkThis.Worksheets(WshtCrntName)
        WshtCrnt.Visible = xlSheetVisible
        WbkThis.Worksheets(WshtCrntName).Copy after:=.Worksheets(.Worksheets.Count)
        WshtCrnt.Visible = xlSheetVeryHidden
      Else
        ' This assumes all the names are on the left of the range
        Exit For
      End If
    Next

    ' Delete default worksheets
    For Each WshtCrnt In .Worksheets
      If Left$(WshtCrnt.Name, 5) = "Sheet" Then
        ' Delete worksheet without displaying confirmation dialog box
        Application.DisplayAlerts = False
        WshtCrnt.Delete
        Application.DisplayAlerts = True
      Else
        ' New sheets were added on right so default sheets are on the left
        Exit For
      End If
    Next

  End With

  ' Don't worry about the extension. Let Excel decide which is best.
  WbkDestName = Format(Now(), "yymmdd hhmmss")

  WbkDest.SaveAs (WbkThis.Path & "\" & WbkDestName)
  WbkDest.Close

End Sub

你似乎有两本作业本。一个包含宏和源数据，另一个由宏创建，填充选定数据，然后通过电子邮件发送。要处理此问题，有两个工作簿变量：Sourcewb和Destwb。这两个变量都设置为Active工作簿

以下可能是正确的：

Set Sourcewb = ActiveWorkbook

虽然我更喜欢：

Set Sourcewb = ThisWorkbook

ActiveWorkbook是用户启动宏或宏已激活的工作簿。此工作簿是包含宏的工作簿

例如，假设用户打开工作簿Xxx和Yyy，然后从Xxx运行Yyy中的宏。Xxx是活动工作簿，Yyy是此工作簿。您可能认为您的用户永远不会从另一个工作簿运行宏，但我已经看到了

如果Destwb应该是一个新的空工作簿，则需要的语句是：

Set Destwb = Workbooks.Add

这将创建一个新的默认工作簿并将Destwb设置为该工作簿。“默认工作簿”指的是，如果您要求新工作簿，Excel为您创建的任何工作簿。对我来说，这是一本有三张空白工作表的工作簿，分别名为“Sheet1”、“Sheet2”和“Sheet3”。您的默认工作簿可能不同；例如，“Sheet”可替换为当地语言中表示“Sheet”的单词

试试这个：

从键盘创建新工作簿。对我来说，该工作簿将命名为“Book1”，因此“Book1”将显示在任务栏中。 打开Visual Basic编辑器并将以下代码复制到新模块。 运行宏Test1。

在我的系统上，立即窗口中显示以下内容：

Book1
Book1
Book1
Book2

当前两个Debug.Print语句执行时，只有一个打开的工作簿，This工作簿和Active工作簿都引用它。对于后两个Debug.Print语句，有两个打开的工作簿。此工作簿未更改，但ActiveWorkbook现在引用新工作簿

您希望从源工作簿加载控制参数，以便每个站点都有自己的版本。这是一种很好的方法，可以让相同的代码为不同的用户做不同的事情。但是，您已使代码尽可能难以理解。考虑：

If Not ActiveSheet.Name = Sheets("Tracker").Range("B7").Value Then
    ActiveSheet.Name = Sheets("Tracker").Range("B7").Value
End If

我推断工作表“跟踪器”的B7单元格包含包含参数的工作表的名称。但是，您可以使用它重命名活动工作表。这就是你的意思吗？我认为下面的说法更合适

Dim ParamsWs As Worksheet

Set ParamsWs = Worksheets("Tracker").Range("B7").Value

我还会将密码复制到一个变量：

Dim Password As String

Password = Worksheets("Passwords").Range("D8").Value

我用的是工作表而不是工作表。这就是我的学究气；我更喜欢明确我引用的是哪种类型的工作表。由于WorksheetsPasswords.RangeD8.Value只能访问一次，因此将其值复制到变量中可以保存任何内容，但我认为这会使代码更加清晰。访问工作表比访问变量慢，因此您不希望访问同一单元格两次。更重要的是，目前还不清楚这些细胞含有什么。您现在可能知道，但在六个月或十二个月内何时需要更新此宏呢？如果其他人必须更新此宏怎么办？为什么你让人很难理解你在做什么

考虑：

If Not ActiveSheet.Name = Sheets("Tracker").Range("B7").Value Then
    ActiveSheet.Name = Sheets("Tracker").Range("B7").Value
End If

If Sheets(Sheets("Tracker").Range("L7").Value).Range("D6") > 0 Then
  SendTo = Sheets(Sheets("Tracker").Range("L7").Value).Range("D6")
End If   

这可以简化为：

With ParamsWs
  If .Range("D6").Value > 0 Then
    SendTo =.Range("D6").Value
  End If
End With   

请注意，我将句点保留在RangeD6.Value之前。如果没有句点，则引用活动工作表。对于句点，它引用With语句指定的工作表

此单元格包含字符串，因此不应将其与零进行比较。以下是正确的：

  If .Range("D6").Value <> "" Then
    SendTo =.Range("D6").Value
  End If

注：我在每次作业结束时都增加了.Value。这又是我的迂腐。值是范围的默认属性，可以省略，但如果始终指定该属性，则认为代码更清晰

嵌套严重的If语句似乎正在设置任何可见的指定工作表。这有必要吗？他们有可能被隐藏起来吗？由于If语句是嵌套的，因此不检查一个空白单元格和其余单元格。这是正确的吗？如果它是正确的，它重要吗？以下情况是否可以接受

Dim CellCrnt As Range

With ParamsWs
  For Each CellCrnt In .Range("C8:K8")
    If CellCrnt.Value <> "" Then
      Worksheets(CellCrnt.Value).Visible = True
    End If
  Next
End With

然后X可以保存范围为-2147,4的数字 83648和+2147483647

如果我写：

X = "abc"

我将得到一个“类型匹配”错误。正确地键入变量可以真正帮助避免赋值错误。但是，有时您需要一个不限于单一类型的变量。我可以写：

Dim X As Variant

X = "abc"
X = 5
X = True

使用这段代码，X将依次保存一个字符串、一个整数和一个布尔值。我无法想象这个功能的用途，但下面的内容非常有用

Dim X As Variant

X = Range("A1").Value
X = Range("A1:F1").Value
X = Range("A1:A20").Value
X = Range("A1:F20").Value

对于第一条语句，我不知道单元格A1包含什么类型的值，但这并不重要，X将保存它

在其他语句中，我加载一部分行、一部分列和一个矩形；也就是说，我加载了几个不同类型的值。在每种情况下，X都将保存一个二维数组，第一个维度保存行，第二个维度保存列

这有两个好处。1将一大块单元格复制到变量中，然后访问变量中的值可能比从工作表中单独访问值快得多。2访问同一代码块中的多个工作表可能会变得复杂。将数据复制到变量可以简化代码

我已将RangeC8:K8加载到advantage 2的变体中

如果我是正确的，这段代码将演示您所寻求的功能

Option Explicit
Sub CreateNewWorkbook()

  Dim ColWtcCrnt As Long
  Dim WbkDestName As String
  Dim WshtCrnt As Worksheet
  Dim WshtCrntName As Variant
  Dim WshtParam As Worksheet
  Dim WshtToCopy As Variant
  Dim WbkDest As Workbook
  Dim WbkThis As Workbook

  Application.ScreenUpdating = False

  Set WbkThis = ThisWorkbook

  Set WshtParam = Worksheets(WbkThis.Worksheets("Tracker").Range("B7").Value)

  ' Load range into a variant as a 2D array
  WshtToCopy = WshtParam.Range("C8:K8")

  Set WbkDest = Workbooks.Add

  With WbkDest

    For ColWtcCrnt = 1 To UBound(WshtToCopy, 2)
      WshtCrntName = WshtToCopy(1, ColWtcCrnt)
      If WshtCrntName <> "" Then
        Set WshtCrnt = WbkThis.Worksheets(WshtCrntName)
        WshtCrnt.Visible = xlSheetVisible
        WbkThis.Worksheets(WshtCrntName).Copy after:=.Worksheets(.Worksheets.Count)
        WshtCrnt.Visible = xlSheetVeryHidden
      Else
        ' This assumes all the names are on the left of the range
        Exit For
      End If
    Next

    ' Delete default worksheets
    For Each WshtCrnt In .Worksheets
      If Left$(WshtCrnt.Name, 5) = "Sheet" Then
        ' Delete worksheet without displaying confirmation dialog box
        Application.DisplayAlerts = False
        WshtCrnt.Delete
        Application.DisplayAlerts = True
      Else
        ' New sheets were added on right so default sheets are on the left
        Exit For
      End If
    Next

  End With

  ' Don't worry about the extension. Let Excel decide which is best.
  WbkDestName = Format(Now(), "yymmdd hhmmss")

  WbkDest.SaveAs (WbkThis.Path & "\" & WbkDestName)
  WbkDest.Close

End Sub

---

创建新窗口只会在同一工作簿上打开另一个窗口，而不会创建新的工作簿对象。工作手册。添加可能是您正在寻找的。嗨，托尼，谢谢您的帮助。如前所述，我是一个新手，自学成才，非常感谢大家的帮助。查看文件的详细信息。该文件的运行方式与网站类似。可悲的是，隐藏床单是绝对必要的，因为人们似乎有能力只摧毁他们能看到的东西。隐藏工作表后，他们无法“意外”删除整个工作表，因为excel不允许这样做。他们也无法隐藏任何东西，非常隐蔽，因此他们不会奇迹般地遇到隐藏的对象。我意识到我目前的代码非常混乱，需要大量整理。我感谢你的帮助和解释。在射程之前。这在不久的将来和今天一样非常有用。然而，该文件实际上是一个巨大的蜘蛛网。您使用ParamsWs引用的表单需要位于收集所有电子邮件信息的位置。SendTo、BCC等。但是，需要检查要复制的工作表名称的单元格所在的范围再次位于不同的工作表中。已经完成了很多操作，因此人们可以在很大程度上编辑文件，而不必真正访问该文件。即使他们拥有密码，并且可以在整个文件中更改密码，他们在销毁方面的能力也非常有限。甚至不得不取消复制和粘贴…目前我缺少的一个大部件是复制多张由设定范围确定的图纸的代码。似乎无法让它发挥作用。除此之外，我是jsut关于与文件的这一部分排序的。

Option Explicit
Sub CreateNewWorkbook()

  Dim ColWtcCrnt As Long
  Dim WbkDestName As String
  Dim WshtCrnt As Worksheet
  Dim WshtCrntName As Variant
  Dim WshtParam As Worksheet
  Dim WshtToCopy As Variant
  Dim WbkDest As Workbook
  Dim WbkThis As Workbook

  Application.ScreenUpdating = False

  Set WbkThis = ThisWorkbook

  Set WshtParam = Worksheets(WbkThis.Worksheets("Tracker").Range("B7").Value)

  ' Load range into a variant as a 2D array
  WshtToCopy = WshtParam.Range("C8:K8")

  Set WbkDest = Workbooks.Add

  With WbkDest

    For ColWtcCrnt = 1 To UBound(WshtToCopy, 2)
      WshtCrntName = WshtToCopy(1, ColWtcCrnt)
      If WshtCrntName <> "" Then
        Set WshtCrnt = WbkThis.Worksheets(WshtCrntName)
        WshtCrnt.Visible = xlSheetVisible
        WbkThis.Worksheets(WshtCrntName).Copy after:=.Worksheets(.Worksheets.Count)
        WshtCrnt.Visible = xlSheetVeryHidden
      Else
        ' This assumes all the names are on the left of the range
        Exit For
      End If
    Next

    ' Delete default worksheets
    For Each WshtCrnt In .Worksheets
      If Left$(WshtCrnt.Name, 5) = "Sheet" Then
        ' Delete worksheet without displaying confirmation dialog box
        Application.DisplayAlerts = False
        WshtCrnt.Delete
        Application.DisplayAlerts = True
      Else
        ' New sheets were added on right so default sheets are on the left
        Exit For
      End If
    Next

  End With

  ' Don't worry about the extension. Let Excel decide which is best.
  WbkDestName = Format(Now(), "yymmdd hhmmss")

  WbkDest.SaveAs (WbkThis.Path & "\" & WbkDestName)
  WbkDest.Close

End Sub