[[20230330180154]] 『【VBA】現在のブックを、指定セルの値を名前としax(はる) ページの最後に飛ぶ

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

 

『【VBA】現在のブックを、指定セルの値を名前として保存し、Outlookメールに添付したい』(はる)

初めて質問させていただきます。VBA初心者です。

以下3点を実行したく、自分なりに調べて記述をしましたが、上手くいきません。
どなたか助けていただけないでしょうか。

・現在のブックを、指定のフォルダに名前を付けて保存
・その際、現在のブック【A1】セルの値を名前にし保存したい
・同時に現在のブックを添付したOutlookメールを立ち上げたい

記述↓ 携帯から打っている為、見づらい箇所がありましたら申し訳ありません

Dim xRg As Range

"Update by Extendoffice 2018/3/7

Private Sub Worksheet Change(ByVal Target As Range)

On Error Resume Next

If Target.Cells.Count > 1 Then Exit Sub

Set xRg Intersect(Range("D7"), Target) If xRg Is Nothing Then Exit Sub

If IsNumeric(Target.Value) And Target.Value> 200 Then

Call Mail_small_Text Outlook

End If

End Sub

Sub Mail_small_Text Outlook()

Dim xOutApp As Object

Dim xOutMail As Object Dim xMailBody As String

Set xOutApp CreateObject("Outlook Application")

Set xOutMail-xOutApp.CreateItem(0)

xMailBody"○○"

On Error Resume Next

With xOutMail

.To= "○○.co.jp"

.CC=""

 .BCC=""

.Subject="○○"

 .Body xMailBod

.This Workbook.SaveAs Filename:="T:ファイルの保存先パス"& ThisWorkbook(Range("A1").Value, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled

.Attachments.Add ThisWorkbook.Path& "\" & ThisWorkbook.Name

.Display

End With

On Error GoTo 0

Set xOutMail- Nothing

Set xOutApp Nothing

End Sub

記述以上

コンパイルエラーでは、SaveAs文のRangeの部分を指摘されます。
どのように修正したらよろしいでしょうか。

< 使用 Excel:unknown、使用 OS:Windows10 >


>携帯から打っている為
VBEからコピペした方が誤解が無いと思いますが、
分かる範囲で回答します。

.This Workbook.SaveAs Filename:="T:ファイルの保存先パス"& ThisWorkbook(Range("A1").Value, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled

上記がそのまま書かれているとしたら、
1)xOutMailというMailItem オブジェクトのプロパティ/メソッドに、
 ThisWorkbookはありません。
2)ThisWorkbook(Range("A1").Value
 ・シートを指定していない
(giraffe) 2023/03/30(木) 21:10:20


ご返信ありがとうございます。
全くの初心者なもので、構文等理解できていませんでした…。
ご指摘頂いた事も、私の理解不足でピンときていないような状況なので、
勉強し直そうと思います。
お手数をお掛けいたしました。
(はる) 2023/03/31(金) 07:23:39

https://stackoverflow.com/questions/68919366/send-to-email-address-saved-in-cell
 ここから持ってきたのかな?
 試してないけど、整頓するとこんな感じ?
    Option Explicit
    Private Sub Worksheet_Change(ByVal Target As Range)
        'Update by Extendoffice 2018/3/7
        Dim xRg As Range
        If Target.Cells.Count > 1 Then Exit Sub
        Set xRg = Intersect(Range("D7"), Target)
        If xRg Is Nothing Then Exit Sub
        If IsNumeric(Target.Value) And Target.Value > 200 Then
            Call Mail_small_Text_Outlook
        End If
    End Sub
    Sub Mail_small_Text_Outlook()
        Dim xOutApp As Object
        Dim xOutMail As Object
        Dim xMailBody As String
        Dim strFileName As String
        Set xOutApp = CreateObject("Outlook Application")
        Set xOutMail = xOutApp.CreateItem(0)
        xMailBody = "○○"
        strFileName = "T:\ファイルの保存先パス\" & Range("A1").Value & ".xlsx"
        ThisWorkbook.SaveAs FileName:=strFileName, _
                            FileFormat:=xlOpenXMLWorkbookMacroEnabled
        With xOutMail
            .To = "○○.co.jp"
            .CC = ""
            .BCC = ""
            .Subject = "○○"
            .Body = xMailBody
            .Attachments.Add strFileName
            .Display
        End With
        Set xOutMail = Nothing
        Set xOutApp = Nothing
    End Sub

(稲葉) 2023/03/31(金) 10:05:44


ご丁寧にありがとうございます。非常に参考になります。
元のコードはそちらから持ってきました!
そこに名前を取得&保存機能を付けようとしておりました。

家でPCが使えない環境なので、週明けに職場で試してみようと思います。
ありがとうございます。
(はる) 2023/03/31(金) 22:05:09


コメント返信:

[ 一覧(最新更新順) ]


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