Question

我正在尝试设置电子邮件VBA以读取特定单元格引用中的信息。我知道我可以放入工作表名称，它将以这种方式工作，但我需要文件能够非常可调。这将用于我们所有的网站，它们都变得安静很多，所以我需要能够让任何人调整文件。

代码需要读取工作表'Tracker'单元格'C6'中的信息，如果它与数字匹配，则将多个工作表复制到创建的电子邮件文件中。

要复制的范围是C8：K8

我目前有吹码：

    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

Answer 1

这不是“做这件事，一切都会好的”回答，因为我不确定你要做什么。相反，它列出了我认为是错误的所有内容，我希望这些内容可以让您更接近您所寻求的代码。

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

以下可能是正确的：

Set Sourcewb = ActiveWorkbook

虽然我更喜欢：

Set Sourcewb = ThisWorkbook

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

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

如果Destwb应该是一个新的空工作簿，那么你想要的语句是：

Set Destwb = Workbooks.Add

这会创建一个新的默认工作簿并为其设置Destwb。通过“默认工作簿”，我的意思是，如果您请求新工作簿，Excel会为您创建。对我来说，这是一个包含三个空工作表的工作簿，名为“Sheet1”，“Sheet2”和“Sheet3”。您的默认工作簿可能不同;例如，“Sheet”可以用本地语言中的单词“Sheet”替换。

试试这个：

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

Option Explicit
Sub Test1()

  Dim Destwb As Workbook

  Debug.Print ThisWorkbook.Name
  Debug.Print ActiveWorkbook.Name

  Set Destwb = Workbooks.Add

  Debug.Print ThisWorkbook.Name
  Debug.Print ActiveWorkbook.Name

End Sub

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

Book1
Book1
Book1
Book2

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

您希望从源工作簿加载控制参数，以便每个站点都可以拥有自己的版本。这是使相同代码为不同用户执行不同操作的绝佳方法。但是，您已使代码尽可能难以理解。考虑：

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

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

Dim ParamsWs As Worksheet

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

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

Dim Password As String

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

我使用Worksheets而不是Sheets。这是我迂腐;我更喜欢明确我引用哪种类型的工作表。由于Worksheets("Passwords").Range("D8").Value只被访问一次，将其值复制到变量确实可以保存任何内容，但我认为它使代码更清晰一些。访问工作表比访问变量要慢，因此您不希望两次访问同一个单元格。更重要的是，目前还不清楚这些细胞含有什么。您现在可能知道但是在六到十二个月内需要更新此宏时又该怎么办？如果其他人必须更新此宏怎么办？你为什么要这么难以理解你在做什么？

考虑：

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

请注意，我已将时间段保留在Range("D6").Value前面。没有句点，这将引用活动工作表。使用句点，它引用With语句指定的工作表。

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

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

然而，If没有任何意义。如果单元格包含""，那么这是SendTo所需的值。该块可以替换为：

With ParamsWs
  SendTo =.Range("D6").Value
  SendCC =.Range("D9").Value
  SendBCC =.Range("D12").Value
  SendBody =.Range("H5").Value
  Subject =.Range("D17").Value
End With

注意我在每个作业结束时添加了.Value。这又是我迂腐。 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

此代码将检查范围中的每个单元格，即使较早的单元格为空白。我使用了For Each语句，增加了一些复杂性，但我相信较小的代码块会补偿。 For Each语句也应该是任何VBA程序员的军械库的一部分。

我认为使用Windows的代码是一个完全的误解。我的猜测是你要将.Range（＆＃34; C8：K8＆＃34;）中指定的工作表复制到新工作簿。这不是用Windows完成的。

请解释你想要做什么，我会尽力帮助。

修改第2部分

下面的宏做我认为你想要的。它会创建一个空的工作簿，将选定的工作表复制到该工作簿并保存，以便通过电子邮件发送。但是，先说几点。

我最近没有复制工作表，并且确实记住了确切的语法。搜索“Excel VBA复制工作表到另一个工作簿”会显示一个页面，显示我该怎么做。如果你可以将你的需求分解为这样的单一步骤，你通常可以找到所需的帮助。

如果我写：

Dim X As Long

然后X可以保持-2,147,483,648和+2,147,483,647范围内的数字。

如果我写：

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）将大块单元格复制到Variant，然后访问Variant中的值可能比从工作表中单独访问值要快得多。（2）在同一代码块中访问多个工作表会变得复杂。将数据复制到Variant可以简化代码。

我已将Range（＆＃34; C8：K8＆＃34;）加载到Variant以获得优势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

VBA电子邮件问题

1 个答案: