[[20151118181913]] 『担当者別でまとめたリストをメールに貼付(アドレ』(未熟者) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『担当者別でまとめたリストをメールに貼付(アドレス・件名含む)、下書きへ保存する(マクロ)』(未熟者)

いつもお世話になっております。
仕事で必要に迫られ困っております。
どなたかご教示頂けないでしょうか。

リストから担当者別に振分、エクセルファイルに保存するというマクロを
以前ご教示頂きました。
[[20150412225946]] (ご教示頂いたコードから変更しております。)

内容を変更し、エクセルファイルに保存するところを
メールに振分データと宛先、Cc、件名を転記し、
下書きへ保存するコードに変更を考えております。
大変お手数をお掛けいたしますが何卒ご教示頂きたくよろしくお願い申し上げます。

A     B  C  D  E
1 社員名  商品No. 商品名  上司ID  上司名 
2 あああ  0000  AAA   6666   ○○
3 いいい  1111  BBB  6666   ○○
4 ううう  2222  CCC  7777   ■■
5 えええ  3333  DDD   8888   △△
6 おおお  4444  EEE  8888   △△

  ↓

【マクロ処理後】

A  B  C  D  E  F  G
1
2    ○○(←上司名)
3
4
5
6
7 2015年度商品売上リスト
8
9 ××××××××××××××
10 ××××××××
11
12___________
13 |氏名 |商品No.|商品名∣
14 |あああ| 0000 |AAA∣
15 |いいい| 1111 |BBB∣    ※罫線をひきたいです。
16
・ ※余分な空白を削除してテンプレートに内容説明
・ ××××××××××××××

・ ××××
・ ××××××××××××××
・ ××××××××××××××

・ ××××
・ ××××××××××××××
・ ××××××××××××××

 ↓

【メールへ転記】

To:○○
Cc:□□
件名:○○○■■■

※マクロ処理後の内容と同じ内容を貼付しようと考えています。

コードを念のため貼り付けます。

Dim z As Long

    Dim x As Long
    Dim shm As Worksheet
    Dim sht As Worksheet
    Dim c As Range
    Dim tSh As Worksheet
    Dim fList As Range
    Dim i As Long
    Dim svPath As String
    Dim fName As String
    Dim ff As Variant
    Dim fd As Object
    Dim Shell As Object, myPath As Object
    Dim hWnd As Long
    Dim r As Range
    Dim nBK As Workbook
    Dim wb As Workbook

    Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
    Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示

    'ブックの選択
    ff = Application.GetOpenFilename("Excelブック,*.xls*", , "担当者別に振り分けたいファイルを選んでください")
    If ff = False Then Exit Sub     'キャンセルボタン

    '保存フォルダの選択
    hWnd = Application.hWnd
    Set Shell = CreateObject("Shell.Application")
    Set fd = Shell.BrowseForFolder(hWnd, "保存フォルダを選んでください", _
                                        BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)

    If fd Is Nothing Then Exit Sub      'キャンセルボタン

    svPath = fd.Items.Item.Path & "\"

    'Application.ScreenUpdating = False

    Set wb = Workbooks.Open(ff)  'ファイルを作成する基データを開く
    Set shm = wb.Sheets("連絡用")
    Set sht = ThisWorkbook.Sheets("連絡事項")

    z = shm.Cells(1, Columns.Count).End(xlToLeft).Column
    x = shm.Range("A" & Rows.Count).End(xlUp).Row - 1
    shm.Columns("D").Copy shm.Cells(1, z + 2)
    shm.Columns(z + 2).RemoveDuplicates Columns:=1, Header:=xlYes
    shm.Cells(1, z + 4).Value = shm.Range("D1").Value
    shm.Cells(1, z + 6).Resize(, 5).Value = shm.Range("A1:E1").Value

    For Each c In shm.Cells(1, z + 2).CurrentRegion
        If c.Row > 1 Then
            shm.Cells(2, z + 4).Value = c.Value
            shm.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=shm.Cells(1, z + 4).Resize(2), CopyToRange:=shm.Cells(1, z + 6).Resize(, 5), Unique:=False
            With shm.Cells(1, z + 6).CurrentRegion.Resize(, 3)
                  sht.Range("C14:E43").ClearContents
                  Intersect(.Cells, .Cells.Offset(1)).Copy sht.Range("C14")
            End With

            sht.Range("C2").Value = shm.Cells(3, z + 10).Value
            sht.Range("C14").CurrentRegion.Borders.LineStyle = xlContinuous
            sht.Copy
            Set nBK = ActiveWorkbook

            With nBK.Sheets(1)
                On Error Resume Next
                Set r = .Range("C14:C43").SpecialCells(xlCellTypeBlanks)
                On Error GoTo 0
                If Not r Is Nothing Then r.EntireRow.Delete
            End With

            Range("A1").Select


※ こちらの部分にメールに振分データと宛先、Cc、件名を転記をしたいと考えております。

           '作成したファイルを保存し、閉じる

            fName = "○○○■■■" & shm.Range("O2").Value & " " & shm.Range("P2").Value & ".xlsx"
            Application.DisplayAlerts = False
            With ActiveWorkbook
                    .SaveAs svPath & fName
                    .Close
                End With
          End If

    Next

    '元の状態に戻す

    shm.Cells(1, z + 2).CurrentRegion.Clear
    shm.Cells(1, z + 4).CurrentRegion.Clear
    shm.Cells(1, z + 6).CurrentRegion.Clear
    sht.Range("C2").Clear
    sht.Range("C14:E43").Clear
    Range("A1").Select
    shm.Parent.Close False

    Application.ScreenUpdating = True
    MsgBox "ファイルを作成しました。"

 End Sub

何卒よろしくお願い申し上げます。

< 使用 Excel:Excel2013、使用 OS:Windows7 >


 Outlookを使って、下書きに保存する部分を書きます。
 参考にしてみてください。

 Sub メール作成()
     'Microsoft Outlook xx.x Object Library の参照設定が必要

     Dim oApp As Object
     Dim myNamespace As Object
     Dim myFolder As Object

     Dim objMAIL As Object

     Dim strMOJI As String

     Set oApp = CreateObject("Outlook.Application")
     Set myNamespace = oApp.GetNamespace("MAPI")
     Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
     myFolder.display

     Set objMAIL = oApp.CreateItem(olMailItem)
     objMAIL.display
     objMAIL.BodyFormat = 2    'HTML形式

     '' ***** ここから先を繰り返す。

         objMAIL.To = "送付先のメールドレス"
         objMAIL.CC = "cc先のメールアドレス"
         objMAIL.Subject = "メールの件名"

        'ここにフィルタオプションで抽出するコードを書きます。

         With oApp.ActiveInspector.WordEditor.Windows(1)
             strMOJI = "送信します。"        ' 本文
             .Selection.TypeText strMOJI

             'フィルタオプションで抽出した範囲を指定して、
             'メールに表としてコピーペイスト
             ThisWorkbook.Worksheets("Sheet1").Range("A1:E5").Copy
             .Selection.PasteExcelTable False, False, True
             Application.CutCopyMode = False

             '残りの部分は説明が無いので、
             '上を参考にして適当にトライしてみて下さい。 

         End With

         objMAIL.Close olSave '下書きに保存してから閉じる
         ''''objMAIL.send    'メール送信

     '' ****** ここまでを繰り返す。
 End Sub

(γ) 2015/11/25(水) 22:20


γさん

ご連絡が大変遅くなり大変申し訳ありません。
早速、トライしてみたのですが、
つまづきました。
エクセルで作成したデータがメールにうまく貼り付けることが出来ません。
「実行時エラー 438 オブジェクトは、このプロパティまたはメソッドをサポートしていません。」
と表示されました。

大変お手数をお掛けいたしますがご教示をお願い致します。

     Dim ff As Variant
     Dim メールの件名 As String
     Dim shm As Worksheet
     Dim Ap As Object
     Dim M As Object
     Dim i As Long
     Dim MaxRow As Long
     Dim objMAIL As Object   '送信者の指定
     Dim strSubj As String   '件名
     Dim strTO As String     '宛先(名前指定)
     Dim strCC As String     'CC(名前指定)
     Dim myNamespace As Object
     Dim myFolder As Object
     Dim z As Long
     Dim x As Long
     Dim ans As Integer
     Dim 連絡日 As Date
     Dim 年度 As String
     Dim sht As Worksheet
     Dim c As Range
     Dim tSh As Worksheet
     Dim fList As Range
     Dim svPath As String
     Dim fName As String
     Dim Re As Variant
     Dim fd As Object
     Dim Shell As Object, myPath As Object
     Dim hWnd As Long
     Dim r As Range
     Dim nBK As Workbook

    Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
    Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示

    '送信用ファイルの選択
    ff = Application.GetOpenFilename("Excelブック,*.xls*", , "配信リストを選んで下さい")
    If ff = False Then Exit Sub     'キャンセルボタン

    Set wb = Workbooks.Open(ff)

    '送信用ファイルの起動
    Set shm = wb.Sheets("報告")

    'Outlookの起動
    Set Ap = CreateObject("Outlook.Application")

    メールの件名 = Application.InputBox("例:結果のご連絡" & vbLf & "例:結果のご連絡", _
                                        "メールの件名を入力してください", _
                                        "結果のご連絡")

    'フォームの日付確認
    Re = MsgBox("日付等確認しましたか?", vbYesNo + vbExclamation, "マクロ実行前の確認")
    If Re = vbNo Then
        Exit Sub

    End If

    '連絡Sheetの選択

    ans = MsgBox("業績評価の作成でよろしいですか?", vbQuestion + vbYesNo)

    If ans = vbYes Then

          Set sht = ThisWorkbook.Worksheets("月")

          連絡日 = Application.InputBox("「メール送信予定日」を入力してください" & vbLf & "例:2015/12/9", "", Format(Date))

          sht.Range("C4") = 連絡日

          年度 = Application.InputBox("「標題」を入力してください" & vbLf & "例:評価結果のご連絡", "", "評価結果のご連絡")

          sht.Range("A7") = 年度

        Else

          Set sht = ThisWorkbook.Worksheets("週")

          連絡日 = Application.InputBox("「メール送信予定日」を入力してください" & vbLf & "例:2015/12/9", Format(Date))

          sht.Range("C4").Value = 連絡日

          年度 = Application.InputBox("「標題」を入力してください", "", "結果のご連絡")

          sht.Range("A7") = 年度

        End If

    Set wb = Workbooks.Open(ff)                                         'ファイルを作成する基データを開く

    'Outlookへメールの宛先、件名の転記

    Set shm = wb.Sheets("★連絡用")

    MaxRow = shm.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To MaxRow

    strTO = Cells(i, 6)
    strCC = Cells(i, 7)
    strSubj = メールの件名

     Set M = Ap.CreateItem(0)
         M.BodyFormat = 3                                    'リッチテキスト形式
         M.SentOnBehalfOfName = "kouka@veriserve.co.jp"      '差出人の指定(kouka)
         M.To = strTO                                        '宛先アドレス
         M.CC = strCC                                        'Ccアドレス
         M.Subject = strSubj                                 '件名
         'M.Display                                           '画面を表示

    z = shm.Cells(1, Columns.Count).End(xlToLeft).Column
    x = shm.Range("A" & Rows.Count).End(xlUp).Row - 1
    shm.Columns("D").Copy shm.Cells(1, z + 2)
    shm.Columns(z + 2).RemoveDuplicates Columns:=1, Header:=xlYes
    shm.Cells(1, z + 4).Value = shm.Range("D1").Value
    shm.Cells(1, z + 6).Resize(, 5).Value = shm.Range("A1:E1").Value

    For Each c In shm.Cells(1, z + 2).CurrentRegion
        If c.Row > 1 Then
            shm.Cells(2, z + 4).Value = c.Value
            shm.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=shm.Cells(1, z + 4).Resize(2), CopyToRange:=shm.Cells(1, z + 6).Resize(, 5), Unique:=False
            With shm.Cells(1, z + 6).CurrentRegion.Resize(, 3)
                  sht.Range("C14:E43").ClearContents
                  Intersect(.Cells, .Cells.Offset(1)).Copy sht.Range("C14")
            End With

            sht.Range("C2").Value = shm.Cells(3, z + 10).Value
            sht.Range("C13").CurrentRegion.Borders.LineStyle = xlContinuous
            'sht.Copy

            With Ap.ActiveInspector.WordEditor.Windows(1) ※ここで停まります。
             strMOJI = "送信します。"        ' 本文
             .Selection.TypeText strMOJI

             'フィルタオプションで抽出した範囲を指定して、
             'メールに表としてコピーペイスト
             .sht.Range("A1:H53").Copy
             .Selection.PasteExcelTable False, False, True

             'Application.CutCopyMode = False
             End With

         End If
    Next
         M.Save            '下書き保存
         M.Close 2          'ファイルを閉じる

   Next i

 '元の状態に戻す

    shm.Cells(1, z + 2).CurrentRegion.Clear
    shm.Cells(1, z + 4).CurrentRegion.Clear
    shm.Cells(1, z + 6).CurrentRegion.Clear
    sht.Range("C2").Clear
    sht.Range("C14:E43").Clear
    Range("A1").Select
    shm.Parent.Close False

    MsgBox "メールを作成しました。"

End Sub
(未熟者) 2015/11/26(木) 20:33


ところで、私の提示した最小限のコードは動いたのでしょうか。
もちろん私は動作確認した上で示しているわけですが、
そちらの環境では動かないのでしょうか。
まずはそれに触れていただきたいですね。

そして、徐々に拡張していってはどうでしょうか?
(γ) 2015/11/26(木) 22:34


 最初は、
  'M.Display
 と非表示にしているせいかと思っていましたが(失礼)、
 Outlook2013では仕様が変更になっているようです。

 私はOutlook2010しか手元に無いので、詳細を検証できませんが、
https://msdn.microsoft.com/ja-jp/library/office/ff868098.aspx
 を参考にしてください。

 下書きフォルダを相手に Saveをしないとダメだと思うし、(少なくともOutlook2010では)
 色々と不備な点が残っているようです。
 ただ、それらのデバッグは、基本的にご自分でなさることだと思います。

(γ) 2015/11/28(土) 11:17


 >            With Ap.ActiveInspector.WordEditor.Windows(1)

 >             .sht.Range("A1:H53").Copy

 ここ間違ってますよね。
(cai) 2015/11/28(土) 17:13

 >ここ間違ってますよね。
 そうですね。エラーになるはずですからわかると思いました。
 そのほか、
 ・シートが特定されていないRangeの使用
 ・未宣言変数の使用
 なども修正したほうが良いと思います。

 ■さて、回答コードを提供する自動機械でもないので、
 勝手なことも書かせていただく。
 それは問題へのアプローチの仕方に関してです。
 案外そうしたことが理解できていないんじゃないかな。

 クリアーしたい課題は何ですか?
 メールデータを作ってそれをいったん下書きフォルダに保存することなんでしょ?
 その大事なことから着手することを勧めます。

 その際、重要な点以外は、できるだけシンプルなものにして
 物事を複雑にしないことです。
 まずは、ひとつのデータで実行できるようにする。
 それができるようになったら、
 繰り返しデータを対象にします。

 それ以外の、細々とした入力指示だとか、できました表示とか、
 そんなことは邪魔になるだけです。
 肝心なことができてから、いくらでもそちらでやってください。

 ■基本部分の構築にあたって、こちらも検証したコードを提示しているんだから、
 それをできるだけ活かして下さいよ。
 下書きフォルダだって伊達に指定しているわけじゃない。

 ■追加で、ポイントと思われる点に触れます。
 表以外の情報は、むしろ、テキストだけを貼り付けた方が綺麗かも知れない。
 それには、
   .Selection.PasteSpecial DataType:=2 'wdPasteText
 のような記法を使うとよいでしょう。

(γ) 2015/11/28(土) 20:29


γさん

返信が大変遅くなり申し訳ございません。
体調を崩し、寝込んでおりました。

多岐にわたりご教示頂きまして有難うございます。
大変参考になります。

2015/11/26(木) 22:34 にご回答頂きました件は、
頂いたコードをそのまま使用させて頂きますと、
「 Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts)」でマクロが停まります。
内容を確認いたします。

2015/11/28(土) 11:17 にご回答頂きました件は、
これから内容を確認にいたします。

2015/11/28(土) 20:29 にご回答いただきました件は、
おっしゃるとおりです。
クリアしたい課題は、担当者別に振り分けたデータをメールに貼付、宛先などを転記し、
下書きフォルダに保存することです。
本来あるべきコードを完成させてから入力指示など加えていきます。
期限(11/30迄)が迫ってのコード作成をしておりましたのでご教示頂きましたコード以外で先を急いでしまい大変ご迷惑をお掛けいたしました。

With Ap.ActiveInspector.WordEditor.Windows(1)
 .sht.Range("A1:H53").Copy

上記の箇所が違っているとご指摘頂きましたがお恥ずかしい話
理解しておらずどこをどう直してよいかわからない次第のレベルでご教示頂くのは大変浅はかでした。
申し訳ございません。

色々確認、検証いたします。

(未熟者) 2015/11/30(月) 11:01


 最初にお断りしますが、私はOutlook2010しか持っていませんので、
 2013と2010との差に関することは分かりません。
 ですから、これをもって最終発言とさせていただきます。

 どなたか環境をお持ちのかたは、サポートをお願いします。

 いくつか気づいた点をメモしておきます。

 (1)
 >「 Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts)」でマクロが停まります。 
 エラーがでるなら何というエラーですか?
 'Microsoft Outlook xx.x Object Library の参照設定が必要
 と書きましたが、参照設定は間違いなく実行していますか?

 (2)
 >With Ap.ActiveInspector.WordEditor.Windows(1) 
 > .sht.Range("A1:H53").Copy 
 >上記の箇所が違っているとご指摘頂きましたがお恥ずかしい話 
 >理解しておらず
    shtの頭にドットがありますが、変数shtの頭につけても無駄です。
    ドットは不要です。

 ヘルプを参照しながら、頑張ってください。

 # 私は日中はアクセスできませんので、返答が遅くなったことを了解願います。

(γ) 2015/11/30(月) 21:45


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.