エクセルでセル内容でpdfで保存しメールの起動まで

このQ&Aのポイント
  • エクセルでセル内容を指定してPDFファイルを保存し、メールを起動する方法について質問があります。
  • コードを入力してマクロを作成しているのですが、特定の条件でエラーが発生してしまいます。
  • 具体的には、ファイル名のセルを変更した際に「実行時エラー13、型が一致しません」というエラーが表示されます。
回答を見る
  • ベストアンサー

エクセルでセル内容でpdfで保存しメールの起動まで

長くなってしまって済みません。 先日(2018/12/28)ここで上記のマクロのコードを教えてもらって問題なく使い始めたのですが、別のBookにコピーして、ファイル名のセルを(10,4)と(1,1)から(15,4)と(1,1))に変更すると「実行時エラー 13、型が一致しません」と出ます。 うまくいっているシートのファイル名はD10+A1のセルで、今度はD15+A1をファイル名にしただけなのですが。。。。 (10,4)と(1,1)のままだと普通にメールが起動してくるのですがD10が空白セルの為A1の内容だけでファイル名になってしまいます。 ちなみにそのシートのD10に数値+アルファベットを入れると「型が一致しません」と上記と同じエラーが出ます。 教えてもらったコードのファイル名の(下の)セルの数値だけ変えたらうまくいったと思うのですが、今回はなぜかエラーになってしまいます。 質問ではA1+B1で質問しましたので(1,1)と(1,2)になっています。 xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf" 全部のコードは下記の通りです。 Option Explicit Sub Saveaspdfandsend() Dim xSht As Worksheet 'Dim xFileDlg As FileDialog Dim xFolder As String 'Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Const PdfDir = "C:\OKWave"  'PDFを保存するフォルダー Set xSht = ActiveSheet 'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) ' 'If xFileDlg.Show = True Then '  xFolder = xFileDlg.SelectedItems(1) 'Else '  MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" '  Exit Sub 'End If xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf" 'Check if file already exist 'If Len(Dir(xFolder)) > 0 Then '  xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ '           vbYesNo + vbQuestion, "File Exists") '  On Error Resume Next '  If xYesorNo = vbYes Then '    Kill xFolder '  Else '    MsgBox "if you don't overwrite the existing PDF, I can't continue." _ '          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" '    Exit Sub '  End If '  If Err.Number <> 0 Then '    MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ '          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" '    Exit Sub '  End If 'End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then   'Save as PDF file   xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard      'Create Outlook email   Set xOutlookObj = CreateObject("Outlook.Application")   Set xEmailObj = xOutlookObj.CreateItem(0)   With xEmailObj     .Display     .To = ""     .CC = ""     .Subject = ""     .Attachments.Add xFolder     'If DisplayEmail = False Then       '.Send     'End If   End With Else  MsgBox "The active worksheet cannot be blank"  Exit Sub End If End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • HohoPapa
  • ベストアンサー率65% (454/690)
回答No.1

xFolder = PdfDir + "\" + xSht.Cells(15, 4).Text & xSht.Cells(1, 1).Text + ".pdf" とすると期待通り動くものと思います。

akira0723
質問者

お礼

早々のご回答ありがとうございます。 最初はどこが違うのか分かりませんでしたが、並べてみたらValueがTEXTになっていました。 最初のBookではC&Pの後数字だけ変えてValueのままで動いたのに不思議です。 このコードはこれからも汎用になるので、こんなレベルで使うには少し不安もありますが今更以前のように、(1)ファイル名をつけて、(2)所定のフォルダを探して、(3)pdfで保存して、(4)そのファイルをフォルダから探して、(5)メールに添付して、(6)シートごとに決まった宛名を入れて送信。。。はできないので非常に助かりました。 複数の人がこの作業をやるのですが、1人の人には上記の6つの作業はハードルが高く、1人の人は入力ミスが多いので本当に助かりました。

akira0723
質問者

補足

いつもお世話になっております。 早々かつ度々のご回答ありがとうございます。 朝一で「動かない」と指摘されて、最初のBookでは何度やっても問題なく動くことから、セル番地だけの問題と何度も試行錯誤していたのが全く無駄だったことに無力感、とすんなり解決したことに感謝です。

その他の回答 (2)

  • HohoPapa
  • ベストアンサー率65% (454/690)
回答No.3

(2018/12/28)の時には、掲示サイトからそのままコピペしました。 よく見ると文字演算で + を使っていますね。 xFolder = PdfDir & "\" & xSht.Cells(15, 4).Text & xSht.Cells(1, 2).Text & ".pdf" とすれば、より確実です。  

akira0723
質問者

お礼

本当に色々ありがとうございます。 +は使用した覚えがなく、というかそんな知識がありません。 ここからコピペしたときに+になったハズです。 同じような現象で¥は\になるものと思いました。 ご回答コードを\のままマクロに貼り付けたら¥に戻ったと思います。 今確認したらコピペしたはずなのに、同じ行に+と&が混在していましたので原因(規則性)不明。 気持ち悪いので&に修正して(も)正常に動くことを確認しました。 残念ながら当方に\を+に変える知識はありません。(ご存知の通り)

  • watabe007
  • ベストアンサー率62% (476/760)
回答No.2

>質問ではA1+B1で質問しましたので(1,1)と(1,2)になっています。 >xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf" >(15,4)と(1,1))に変更すると Range("D15") と Range("A1") ですね なら xFolder = PdfDir & "\" & xSht.Range("D15").Value & xSht.Range("A1").Value & ".pdf" 文字の連列は & で行いましょう MsgBox xFolder で連結後の確認もしてみましょう

akira0723
質問者

お礼

ご回答でうまく行くことが確認出来ました。 Range()で出来ないのはなぜ?が有ったので色々試行錯誤してみたところ、指定したセルが空白の場合はエラーになるようです? ちょっとした確認不足、大きな知識不足ですみませんでした。 上記訂正とお詫びします。

akira0723
質問者

補足

いつもお世話になっております。 早々のご回答に感謝!! 試してみたのですが赤●の中に×が入って400というエラー表示が出ます。 他のマクロではRange()を使っているので、Range()でも行けるということだと思いますが当方のことですので何かの手違いも。。。自信なし。 いずれにしても#No1さんのご回答で解決しましたのでこれ以上のお手数は結構です。

関連するQ&A

  • エクセルをVBAでOUTLOOKで送信したい(再)

    数年前にエクセルをPDFにして添付ファイルとしてOUTLOOKで送信するコードを教えてもらって毎日のように便利に使っているのですが、今回は元のマクロ付きエクセルのまま同じことがしたく、試行錯誤でpdfをxlmsに変えてみたら、メールは起動して来るのですが 「ファイルが見つかりません」とエクセルが添付されません。 どなたかどこを修正すれば良いのかHELPお願いします。 Option Explicit Sub Saveaspdfandsend() Dim xSht As Worksheet 'Dim xFileDlg As FileDialog Dim xFolder As String 'Dim xYesorNo As Integer Dim xOutlookObj As Object Dim xEmailObj As Object Dim xUsedRng As Range Const PdfDir = "\\XXXX\TEST報告書成績表" 'PDFを保存するフォルダー Set xSht = ActiveSheet 'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) ' 'If xFileDlg.Show = True Then '  xFolder = xFileDlg.SelectedItems(1) 'Else '  MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" '  Exit Sub 'End If xFolder = PdfDir & "\" & xSht.Cells(22, 5).Value & " " & xSht.Cells(1, 1).Value & ".pdf" 'Check if file already exist 'If Len(Dir(xFolder)) > 0 Then '  xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _ '           vbYesNo + vbQuestion, "File Exists") '  On Error Resume Next '  If xYesorNo = vbYes Then '    Kill xFolder '  Else '    MsgBox "if you don't overwrite the existing PDF, I can't continue." _ '          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro" '    Exit Sub '  End If '  If Err.Number <> 0 Then '    MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _ '          & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File" '    Exit Sub '  End If 'End If Set xUsedRng = xSht.UsedRange If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then 'Save as PDF file xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard 'Create Outlook email Set xOutlookObj = CreateObject("Outlook.Application") Set xEmailObj = xOutlookObj.CreateItem(0) With xEmailObj .Display .To = "-----.co.jp" .CC = "----.co.jp" .Subject = "XXX報告書" & " " & Range("D10") .Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部" .Attachments.Add xFolder 'If DisplayEmail = False Then '.Send 'End If End With Else MsgBox "The active worksheet cannot be blank" Exit Sub End If End Sub

  • 【Excelマクロ】もっと頭の良い書き方って無いかな?

    5行空白列があったらそこで処理を終わりたいんですが、もっといい書き方はないでしょうか? 下記が私の考えた頭の悪いやり方です。 Sub macro() Dim i As Integer For i = 1 To 1000 If Cells(i, 1) = "" Then  If Cells(i + 1, 1) = "" Then   If Cells(i + 2, 1) = "" Then    If Cells(i + 3, 1) = "" Then     If Cells(i + 4, 1) = "" Then      If Cells(i + 5, 1) = "" Then       MsgBox (i - 1 & "行目で終わりです")       Exit For      End If     End If    End If   End If  End If End If Next End Sub

  • DTPickerで入力したらの検索が出来なくなりました。

    お世話になります。 質問ですが 以下のVBAコードがあります。Sheet3のCells(2, 6)に記入した日付によってSheet1の検索を一部行うのですが、Cells(2, 6)への入力をDTPickerを使って行うようにしたら該当する日付がありませんのエラーが帰ってきます。たぶん書式が違うせいかなと思うのですがどうすればいいのでしょうか? どなたか分かる方いらっしゃいますか?よろしくお願いします。  Private Sub CommandButton1_Click() Dim trgA As Variant, trgB As Variant With Worksheets("Sheet3") If IsEmpty(.Cells(2, 7)) Then MsgBox "個数が空です。", vbCritical: Exit Sub '日付 trgA = Application.Match(.Cells(2, 6).Value2, Worksheets("Sheet1").Range("A:A"), 0) If IsError(trgA) Then MsgBox "該当する日付がありません。", vbCritical: Exit Sub '製品名 trgB = Application.Match(.Cells(2, 4).Value, Worksheets("Sheet1").Range("2:2"), 0) If IsError(trgB) Then MsgBox "該当する製品名がありません。", vbCritical: Exit Sub If Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = "" Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value Else If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value End If End If End With End Sub

  • Excel VBAで検索(Win2000 Excel2000)

    現在、下記のようなコードを書いています。データテーブルの縦と横の検索値を探してその列数と行数を返したいのですが、下記の Sub検索1 と Sub検索2 を1つのSubで実行させるにはどうしたらよいのでしょうか?よろしくお願い致します。 ----------------------------------------- Sub 検索1() Worksheets("Data").Activate Dim x As Integer For x = 3 To 22 If Cells(2, x).Value >= 12 Then MsgBox x Exit Sub End If Next MsgBox "見つかりません" End Sub --------------------------------------------- Sub 検索2() Worksheets("Data").Activate Dim i As Integer For i = 4 To 42 If Cells(i, 2).Value = "A" Then MsgBox i Exit Sub End If Next MsgBox "見つかりません" End Sub

  • エクセルVBAにて保存するとき

    Private Sub Workbook_BeforeClose(Cancel As Boolean) If MsgBox("エクセルを終了してもよろしいですか?", vbYesNo) = vbNo Then Cancel = True Exit Sub End If Application.DisplayAlerts = False Application.Quit End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox "そのボタンでは保存できません。" & vbCrLf & _ "雛形は残しておきましょう" & vbCrLf & _ "" & vbCrLf & _ "ツールバーの「マクロなし出力」から保存できます。" Cancel = True End Sub という二つのマクロをThisworkbookにいれてあるんですが、 この二つを有効(今は2つ目を'でコメント状態にしてあるので保存可)にすると保存できなくて困っています。 二つを有効にした時はどのようにほぞんすればいいですか?

  • VBAでMP3を鳴らしたい

    vbaについて質問です。 MP3ファイルを鳴らしたいのですがうまくいきません。 --------------------------------------------------------- Sub Macro1() Dim SoundFile As String SoundFile = "C:\終了音.mp3" If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If Shell "mplay32.exe /play /close " & SoundFile End Sub --------------------------------------------------------- を実行すると、 「Shell "mplay32.exe /play /close " & SoundFile」 の部分で 実行時エラー53 ファイルが見つかりません。 になります。 しかし、 If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If の部分では問題ないので、ファイルはある事になってると思うのですが、 なぜ「Shell "mplay32.exe /play /close " & SoundFile」の部分でエラーになるのでしょうか? スペックは、エクセル2007、windows7です。 ご回答よろしくお願いします。

  • エクセル2007 参照セルの値が認識されない

    エクセル2007の環境で下記マクロを実行すると、 アクティブシートのセルA1に数字が入っている場合、Sheet1のセルA1に値を転記しても そのセルA1の値をVLOOKUP関数で参照できません。 マクロに問題があるためなのか何処に問題があるのか分からないので教えてください。 宜しくお願いいたします。 【sheet】は アクティブシートの3行目から1000行目までのA列のセルをクリックしたらセルA1に値を表示 その後、下記【モジュール】を使用し、 アクティブシートのセルA1が空白の場合、 A列の数値をSheet1のセルA1に転記し、アクティブシートのA列の数値が空白になるまで循環する。 Sheet1のセルA1の値をVLOOKUP関数で参照した内容を表示、印刷します。 ----------------------------------------------------------------- '【sheet】 Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Target If .Count > 1 + IsEmpty(.Value) Then Exit Sub If Application.Intersect(.Cells, Range("A3:A1000")) Is Nothing Then Exit Sub ActiveSheet.Cells(1, 1).Value = .Value End With End Sub ----------------------------------------------------------------- '【モジュール】 Sub TEST() Dim myBtn As Integer Dim myMsg As String, myTitle As String Dim WS1 As Worksheet, WS2 As Worksheet Dim i As Long myMsg = "●●●" myTitle = "確 認" myBtn = MsgBox(myMsg, vbYesNo + vbExclamation, myTitle) If myBtn = vbYes Then Set WS1 = ActiveSheet Set WS2 = Sheet1 If WS1.Cells(1, 1).Value = "" Then With WS1 For i = 3 To 65536 If .Cells(i, 1).Value = "" Then Exit For WS2.Cells(1, 1).Value = .Cells(i, 1).Value WS2.Cells(1, 2).Value = ActiveSheet.Name 'WS2.PrintOut Copies:=1 Next i End With ElseIf WS1.Cells(1, 1).Value >= 1 Then WS2.Cells(1, 1).Value = WS1.Cells(1, 1).Value WS2.Cells(1, 2).Value = WS1.Name 'WS2.PrintOut Copies:=1 Else End If End If End Sub -----------------------------------------------------------------

  • エクセルにて、VBAで名前を付けて保存する場合

    こんにちは、色々試しているのですが、うまくいかずに悩んでいます。 コマンドを実行すると、名前を付けて保存のダイアログ画面を表示させるVBAを作りたいです。 ただし、 (1)保存せずに、ダイアログを表示させる状態で停止させる。 (2)ダイアログ表示時、ファイル名欄に”売上集計表yyyy年mm月”というファイル名が入っている。(yyyyとmmは変数。コマンド実行時に入力する事でファイル名もそれに対応する。) 以下の様にVBAを組んだのですが(他にも色々組んでいますが、うまく動いている個所は省いてます。)、上記(1)(2)共に思い通りに動いてくれません。分かるかたがいましたら、よろしくお願いします。 Sub 保存() ' ' Macro1 Macro Dim rtn Dim myD As String, msg As String, fn As String, x As String Dim wb As Workbook, ws As Worksheet line: ' 年月の入力処理 rtn = Application.InputBox("入力する月を西暦YYYYMM形式で入力してください。" _ & vbNewLine & "例)2011年7月⇒201107", Type:=1) If rtn = False Then Exit Sub myD = Left(rtn, 4) & "/" & Right(rtn, 2) & "/01" If Not IsDate(myD) Then MsgBox "存在しない年月です!", vbCritical GoTo line Else If MsgBox(Format(myD, "yyyy年mm月") & "で間違いないですか?", vbYesNo + vbQuestion) = vbNo Then Exit Sub End If End If 'ファイルの保存 ChDir "C:\Users\(ユーザー名)\Desktop\新しいフォルダー" ActiveWorkbook.SaveAs Filename:= _ "C:\Users\(ユーザー名)\Desktop\新しいフォルダー\売上集計表保存" & "Year(myD)" & "年" & "Month(myD)" & "月" & ".xlsm", FileFormat:= _ xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False End Sub

  • vba boolean変数を開放する方法

    エクセルのセルに「○○○○○○○○○○××××××××××」と入っているものをランダムに並べ代えるマクロを探してみました。 Sub macro2() Dim i, m As Integer Dim b, c As String Dim flg(1 To 20) As Boolean b = Cells(1, 1).Value Randomize For i = 1 To 20 Do m = Int(20 * Rnd + 1) If flg(m) = False Then flg(m) = True Exit Do End If Loop c = c & Mid(b, m, 1) Next i Cells(1, 2).Value = c End Sub これはうまく動くのですが、10行分やろうとして、以下のように変更すると暴走(終わらない)します。 Sub macro2() Dim i, m, n As Integer Dim b, c As String Dim flg(1 To 20) As Boolean For n = 1 To 10 b = Cells(n, 1).Value Randomize For i = 1 To 20 Do m = Int(20 * Rnd + 1) If flg(m) = False Then flg(m) = True Exit Do End If Loop c = c & Mid(b, m, 1) Next i Cells(n, 2).Value = c next n End Sub 一行目が終わってもboolean変数の値がそのまま残っているのが原因らしいのですが開放する方法がわかりません。 取りあえずもう一つマクロを追加してやりたいことはできたのですが、 Sub macro1() Dim n As Integer For n = 1 To 10 Call macro2(n) Next n End Sub Sub macro2(n As Variant) 以下略 なんかスッキリしません。 boolean変数を開放し、マクロひとつですます方法を教えて頂きたくお願いします。 flg(m) = Falseを挿入してもダメでした。

  • 数値かどうかを取得したい IsNumberではダメ

    Sub Macro2() Dim mystr As String mystr = "1" If IsDate(mystr) = False Then MsgBox "NO" End If End Sub これなら日付型かどうかを取得できるのに、 Sub Macro1() Dim mystr As String mystr = "1" If IsNumber(mystr) = False Then MsgBox "NO" End If End Sub だと、IsNumberがコンパイルエラーになります。 変数に入っている値が数値として評価できるかを取得する方法を教えてください。

専門家に質問してみよう