0

私はVBAをまったく使用したことがないので、Microsoft Officeで見つけた次のVBAコードについてサポートが必要です（現在Excel 2007を使用しています）。私は3つのことをする方法を知りたいです：

  1. クリックするとコードを実行するボタンを作成します。
  2. ソースワークブックの名前ではなく、アクティブなワークシートの名前で一時ワークブックファイルを保存します。
  3. K列のすべてのメールアドレスを選択し、以下のコードで作成されたメールの受信者として挿入します。

誰かが私にこれを手に入れることができますか？

Sub Mail_ActiveSheet()

    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

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

    Set Sourcewb = ActiveWorkbook
        ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    ' Determine the Excel version, and file extension and format.
    With Destwb
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered NO in the security dialog."
                Exit Sub
            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

    ' You can use the following statements to change all cells in the
   ' worksheet to values.
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    ' Save the new workbook, mail, and then delete it.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = " " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
       ' Change the mail address and subject in the macro before
       ' running the procedure.
        With OutMail
            .To = "laragon2@its.jnj.com"
            .CC = ""
            .BCC = ""
            .Subject = "test"
            .Body = "test"
            .Attachments.Add Destwb.FullName
            .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
4

1 に答える 1

2

1.の場合[Developerタブ]->[Controlsグループ]->insertでボタンを作成し、ボタンを見つけて既存のマクロを割り当てることができます。

2.変更sourcewb.name->activeSheet.name

3.の場合（列Kを想定すると、各セルには各セルに1つの有効な電子メールアドレスが含まれます）

編集あなたは行の後に以下のコードを置くことができます：

Set Sourcewb = ActiveWorkbook

Dim recipients As String
Dim i As Long
Dim height as long

With ActiveSheet
    .Activate
    Height = .Cells(.Rows.Count, 11).End(xlUp).Row ' column k
    For i = 1 To Height
        If .Cells(i, 11).Value <> "" Then 'if that cell contains ONE email address
            recipients = recipients & ";" & .Cells(i, 11).Value 'append it
        End If

    Next i
    If Len(recipients) > 0 Then 'remove the first dummy ";"
        recipients = Mid(recipients, 2)
    End If


End With

そして交換してください

With OutMail
            .To = "laragon2@its.jnj.com"

に

With OutMail
            .To = recipients

編集2：すべて.cells(i,11)の.cells(i,7)11

VBAではcells(ROW,COLUMN)構文が使用されます。

A = 1

B = 2

..。

G = 7

K=11列目など

以下のコードを使用して、元のパーツを置き換えることもできます

Dim recipients As String
Dim i As Long
Dim height As Long
Dim colNum As Long


With ActiveSheet
    .Activate
    colNum = .Columns("K").Column ' You can replace K to G <~~~~ Changes here
    height = .Cells(.Rows.Count, colNum).End(xlUp).Row   '<~~~~ Changes here
    For i = 1 To height
        If .Cells(i, 11).Value <> "" Then 'if that cell contains ONE email address
            recipients = recipients & ";" & .Cells(i, colNum).Value 'append it   '<~~~~ Changes here
        End If

    Next i
    If Len(recipients) > 0 Then 'remove the first dummy ";"
        recipients = Mid(recipients, 2)
    End If


End With
于 2013-02-01T03:15:37.847 に答える