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

エクセルを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つ目を'でコメント状態にしてあるので保存可）にすると保存できなくて困っています。二つを有効にした時はどのようにほぞんすればいいですか？

ＶＢＡでMP3を鳴らしたい

ｖｂａについて質問です。 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 参照セルの値が認識されない

エクセル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で名前を付けて保存する場合

こんにちは、色々試しているのですが、うまくいかずに悩んでいます。コマンドを実行すると、名前を付けて保存のダイアログ画面を表示させるＶＢＡを作りたいです。ただし、 (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がコンパイルエラーになります。変数に入っている値が数値として評価できるかを取得する方法を教えてください。

BASP21を使ってファイル添付メールを送信したい

basp21 pro（http://www.b21soft.co.jp/basp21/）でメールにファイル添付したいのですがエクセルファイルを添付したいのですが、SendMailで型が一致しませんというエラーが出ます。教えてください＞＜；ファイル名に指定しているセルCells(i, 28) は　=AC3&"\"&AD3　の様に場所を指定しています（AD3 部分が変わっていくので。ここを変えた方がいいでしょうか？）内容は一部省略しておりますが　↓です Sub SendMailMacro1() Dim szServer, szTo, szFrom, szSubj, szBody, ret, szLogfile, z As String Dim szFile As Variant Dim i, j As Long Dim fs, a As Object On Error GoTo Err_Handler Set fs = CreateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile("C:\Program Files\log.txt", True) szServer = Worksheets("maildata").Cells(10, 2) szFrom = Worksheets("maildata").Cells(8, 2) With Worksheets("senddata") i = 2 Do While .Cells(i, 1) <> "END" If .Cells(i, 1) = "1" Then If .Cells(i, 3) = "1" Then szTo = .Cells(i, 5) & vbTab & "bcc" & vbTab & .Cells(1, 36) End If szBody = .Cells(i, 26) szSubj = .Cells(i, 25) szFile = .Cells(i, 28) ret = SendMail(szServer, szTo, szFrom, szSubj, szBody, szFile) If Len(ret) <> 0 Then a.WriteLine (Date & " " & Time & " " & ret & "－" & szTo & "－" & szBody) MsgBox "エラー　・・・　" & i & "行目　( " & ret & ")" .Cells(i, 1) = "エラー" Else .Cells(i, 1) = "完了" End If End If i = i + 1 Loop End With MsgBox "終了" GoTo Exit_sub Err_Handler: MsgBox Err.Description, vbCritical, "Error" GoTo Exit_sub Exit_sub: a.Close End Sub 宜しくお願い致します＜（＿＿）＞

エクセルでセルの値がTRUEかFALSEか判定

Q3:R19の表があります。 Q列にはTRUEかFALSEが入りますが、空白や文字列の場合もあります。 R列には文字列です。 Q列でFALSEのセルだけ、同じ行のとなりのR列の文字列を順に抜き出し、メッセージボックスに表示したいのです。下記のようなVBAを書いてみましたが、Q列が空白や文字列の場合まで抽出されてしまいます。これを排除するいい方法はないでしょうか？ Sub test01() 　　Dim msg As String 　　Dim i As Long 　　With Sheets("LOG") 　　　　For i = 3 To 19 　　　　　　If .Range("Q" & i).Value = False Then '　　　　　　　　Debug.Print 　i & "-" & .Range("R" & i).Value 　　　　　　　　msg = msg & .Range("R" & i).Value & vbCrLf 　　　　　　End If 　　　　Next i 　　End With 　　If msg <> "" Then 　　　　MsgBox msg & vbCrLf & "上記により不可です。", vbCritical 　　End If End Sub

エクセル　VBA　シート保存ボタン

Sheet上にボタンを作成ボタンを押すと保存するようにしています！以前ここでSheet2枚をコピー出来るような記述教えてもらったのですが・・ 1枚ならどう変化して良いか・・記述を書きましたが何処が違うか教えて下さい！ Private Sub CommandButton1_Click() 　　Dim FileName　　As String 　　Dim FileExt　　 As String 　　Dim BkName　　　As String 　　Dim OldWkbook　 As Workbook 　　Dim NewWkbook　 As Workbook 　　Const StName1　 As String = "ko" 　　　　' 　　Application.DisplayAlerts = False 　　Set OldWkbook = ActiveWorkbook 　　' 　　'ファイル名を取得　　BkName = OldWkbook.Sheets(StName1).Range("A1").Value 　　FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" 　　' 　　FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) 　　If FileName = "" Then 　　　　Exit Sub 　　Else 　　　　If Right(FileName, 4) <> ".XLS" Then 　　　　　　MsgBox "ファイル名が異常です。" 　　　　　　Exit Sub 　　　　End If 　　End If 　　' 　　OldWkbook.Sheets(Array(StName1)).Copy 　　Set NewWkbook = ActiveWorkbook 　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count 　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete　　　Next 　　NewWkbook.Sheets(1).Name = StName1 　　' 　　FileName = "D:\保存\計画\" & FileName 　　' 　　If Dir(FileName) <> "" Then 　　　　'##ファイルが既に存在する　　　　If MsgBox("既に指定のファイルが存在します。置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then 　　　　　　NewWkbook.Close savechanges:=False 　　　　　　'##保存せずに終了　　　　　　Exit Sub 　　　　End If 　　　　'##指定ファイル置き換え保存　　　　NewWkbook.SaveAs FileName:=FileName 　　Else 　　　　'##ファイルを新規保存　　　　NewWkbook.SaveAs FileName:=FileName 　　End If 　　' 　　NewWkbook.Close savechanges:=False 　　Application.DisplayAlerts = True End Sub 教えて下さい！

アクセスの印刷ＶＢＡを教えて下さい

アクセス初心者です。バージョンは2002を使っています。ネットで探して詳しく分からないままプログラムしています。フォームで印刷のコマンドボタンを作ってそのボタンをクリックすると表示されてる 1ページのみ印刷したいのですが全てのレコードが印刷されてしまいます。どうすればいいのか教えて下さい。下記が今現在のＶＢＡです。 Private Sub 印刷_Click() Dim varCopies As Variant varCopies = InputBox("部数を数字で入力してください", "印刷部数の指定") If Len(varCopies) = 0 Then Exit Sub End If If IsNumeric(varCopies) = False Then MsgBox "部数は数字で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub ElseIf CLng(varCopies) = 0 Then MsgBox "部数は0以上で入力してください", vbOKOnly + vbCritical, "入力エラー" Exit Sub End If If MsgBox("印刷しますか？" & vbCrLf & "部数=" & varCopies _ , vbYesNo + vbInformation, "印刷の確認") = vbYes Then DoCmd.OpenForm "伝票", acPreview, , , acFormReadOnly DoCmd.PrintOut acPrintAll, , , , CLng(varCopies) DoCmd.Close acForm, "伝票" End If End Sub

エクセル　シートのみ　保存

過去の質問も参照しましたが当てはまる物が無くて質問しました！シート上にボタンを作成してクリックするとそのシートのみ指定するファイルにコピーさせたいです！下記の部分で何処を変化させればよいのでしょうか？ (1)～(2)の部分で困っています。 Private Sub CommandButton1_Click() Dim FileName As String Dim FileExt As String ’(1)の質問！○＝の部分をSheets（セルのA1の値をファイル名に入れたいです） FileName = "○"& Format(Now, "yyyy-mm") & ".XLS" '==== FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If '==== FileName = "D:\保存\ケア\計画\" & FileName If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。上書きしますか?", vbOKCancel, "上書きの確認") = vbCancel Then '##保存せずに終了 Exit Sub ElseIf ThisSheets.FullName = FileName Then '##現在開いているファイルと同じなら上書き保存 ThisSheets.Save Else '##指定ファイルを削除した後保存 Kill FileName ThisSheets.SaveCopyAs FileName:=FileName End If Else '##ファイルを新規保存 ThisSheets.SaveCopyAs FileName:=FileName End If ThisSheets.Saved = True End Sub (2)ThisSheets＆指定してもう一つだけ　保存先にコピーしたいです！つまり　２つのSheetのみ保存させたいのですが・・　ここからどのようにしたら良いのか　お願いします！教えて下さい。　

エクセルVBAでPDFを1枚目のみ印刷したい

下記のVBAに複数PDFが重なっている場合は、一枚目のみ印刷する文面を挿入したいのですがうまくいきません Sub Test() Dim z As Object Dim i As Long Dim f, p As String Application.ScreenUpdating = False Set z = CreateObject("WScript.Shell") p = Application.ActivePrinter For i = 1 To Range("A1").End(xlDown).Row f = "h:\hozei\" & Cells(i, 1).Value & ".pdf" If Dir(f) <> "" Then z.Run ("AcroRd32.exe /t " & f) Else Cells(i, 2).Value = Cells(i, 1).Value Cells(i, 1).Value = "" End If Next i Set z = Nothing End Sub お忙しいところ申し訳ございませんどなたかご教示願います。

Excel VBAで新たな保存先のパスの取得方法は？

エクセルＶＢＡで新たに一度に作成する複数のブックを保存するフォルダーをあらかじめ指定したいのですが、下記のような方法しか思い浮かびません。もっとスマートなやり方はないでしょうか？（直接入力以外の方法で） Sub Path_Get() Dim myPath As String, damy As Variant MsgBox "作成するファイルの保存先を選択します。" _ & vbCr & "なお、表示されたファイル名は気にしないで" _ & vbCr & "下さい。（笑）" damy = Application.GetSaveAsFilename(fileFilter:="Excel (*.xls),*.xls") MsgBox damy If damy = False Then Exit Sub For i = Len(damy) To 0 Step -1 If Mid(damy, i, 1) = "\" Then myPath = Mid(damy, 1, i) Exit For End If Next i MsgBox "パスは " & myPath & "です。" End Sub

VBAでExcelファイルのPDF自動化

表題の通りの事をしたいと思っています。とあるサイトで参照したvbaコードで、デスクトップにファイルをExcelのブック名と同じ名前でPDFに変換するところまで出来ました。あと自動でやりたいことは2つあり、(1)とあるセルの情報を読み込み保存名にしたい【○○○.pdfという具合に】、(2)生成したpdfファイルの保存先をマクロ内に設け指定したいです。【\\サーバー名\○○\△△\□□などのように】現状までのコードを表記します。わかる方いらっしゃいましたら、お手数ですがアドバイスお願いします。自分はマクロは手を出したばかりで、初心者です。宜しくお願いします。 Sub pdf() Dim i As Integer Dim s_prn As String, oldprn As String, flg As Boolean On Error Resume Next s_prn = "Adobe PDF" 'インストールされているPDFプリンタの名前 oldprn = ActivePrinter 'アクティブプリンタを取得 If InStr(oldprn, s_prn) = 0 Then '切替えたいプリンタがアクティブプリンタでない場合 flg = False 'プリンタ切替フラグ For i = 0 To 99 ActivePrinter = s_prn & " on Ne" & Format(i, "00") & ":" '「"プリンタ名"on NeXX:」形式PC用 ActivePrinter = "Ne" & Format(i, "00") & ": の " & s_prn '「NeXX: の "プリンタ名"」形式PC用 If ActivePrinter <> oldprn Then flg = True 'プリンタ切替成功 Exit For End If Next i If flg = False Then 'プリンタ切替失敗の場合 MsgBox "プリンタ名:" & s_prn & " が見つかりません。" Exit Sub End If End If ActiveSheet.PrintOut ActivePrinter = oldprn 'アクティブプリンタを元に戻す MsgBox "終了しました。" End Sub

エクセルでマクロを使った保存の件で？

以前　エクセルのセルの中身をhtmlファイルで簡単に保存させたい？と言う質問した者です。 http://oshiete1.goo.ne.jp/qa3616400.html そこで以下のようなコードを教えてもらいました。 Sub htmlコピー() Dim c As Range Dim s As String, TmpS As String Dim myF As Integer On Error Resume Next For Each c In Range("A1").CurrentRegion.Resize(, 1) If c.Value <> "" Then s = Trim(c.Value) TmpS = Right(s, Len(s) - InStrRev(s, ".") + 1) If TmpS <> ".htm" And TmpS <> ".html" Then s = s & ".html" End If myF = FreeFile Open ThisWorkbook.Path & "\" & s For Output As #myF Print #myF, Replace(c.Offset(, 1).Value, vbLf, vbCrLf) Close #myF If Err.Number Then Err.Clear MsgBox c.Address & c.Value Exit Sub End If End If Next End Sub 今回の質問上記の場合はhtmlファイルがエクセルのファイルと同じ場所にできます。これを、もう1つ下の階層（フォルダを新たに作って）に入れる場合はどの辺りをいじればいいのでしょうか？

VBAで2つのBOOKのセル範囲を比較

異なるBOOKのセル範囲のデータを照らし合わせ、不一致があるか確認したいのです。その際、セル範囲をあらかじめVBAで決め打ちするのではなく、画面上で選択したいので、Application.Inputboxを使おうと思います。以下のコードで一応はできたのですが、これを使うためには、画面を分割して2つのBOOKの該当箇所を「並べて比較」で並べて表示させておかなければ片方のシートしか選択することができません。選択範囲が小さい場合は並べて表示させても問題ないのですが、かなり大きな範囲を選択する場合は、並べて表示で画面が半分にされると選択するのが大変です。まず比較元シートを画面全体に表示して範囲選択し、次に比較先を表示して選択できるようにする方法があばとても作業が楽になります。ご教示いただければ幸いです。 Sub 選択範囲データ比較() '2019/05/16 　　Dim myV, myW 　　Dim buf(1) As Range 　　Dim i As Long, m As Long, j As Long 　　　　Set buf(0) = Application.InputBox(Prompt:="セルを選択してください。", Type:=8) 　　myV = buf(0).Value 　　Set buf(1) = Application.InputBox(Prompt:="比較するセルを選択してください。", Type:=8) 　　myW = buf(1).Value 　　If UBound(myV, 1) <> UBound(myW, 1) Then 　　　　MsgBox "配列 1次元要素数が異なります。", vbCritical 　　　　Exit Sub 　　End If 　　If UBound(myV, 2) <> UBound(myW, 2) Then 　　　　MsgBox "配列 2次元要素数が異なります。", vbCritical 　　　　Exit Sub 　　End If 　　For i = LBound(myV, 1) To UBound(myW, 1) 　　　　For n = LBound(myV, 2) To UBound(myW, 2) 　　　　　　If myV(i, n) <> myW(i, n) Then 　　　　　　　　j = j + 1 　　　　　　End If 　　　　Next n 　　Next i 　　If j > 0 Then 　　　　MsgBox j & "個、相違があります。", vbCritical 　　Else 　　　　MsgBox "同一です。" _ 　　　　& vbCrLf & "" _ 　　　　& vbCrLf & "1次元：" & UBound(myV, 1) & "個" _ 　　　　& vbCrLf & "2次元：" & UBound(myV, 2) & "個" 　　End If End Sub

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

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

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

お礼 2019/02/05 13:14

補足 2019/02/05 13:26

その他の回答 (2)

お礼 2019/02/05 17:17

お礼 2019/02/05 16:28

補足 2019/02/05 13:35

関連するQ&A

エクセルをVBAでOUTLOOKで送信したい（再）

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

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

Excel VBAで検索（Win2000 Excel2000）

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

ＶＢＡでMP3を鳴らしたい

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

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

vba boolean変数を開放する方法

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

BASP21を使ってファイル添付メールを送信したい

エクセルでセルの値がTRUEかFALSEか判定

エクセル　VBA　シート保存ボタン

アクセスの印刷ＶＢＡを教えて下さい

エクセル　シートのみ　保存

エクセルVBAでPDFを1枚目のみ印刷したい

Excel VBAで新たな保存先のパスの取得方法は？

VBAでExcelファイルのPDF自動化

エクセルでマクロを使った保存の件で？

VBAで2つのBOOKのセル範囲を比較

注目のQ&A

カテゴリ
一覧

専門家に質問してみよう
専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

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

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

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

お礼 2019/02/05 13:14

補足 2019/02/05 13:26

その他の回答 (2)

お礼 2019/02/05 17:17

お礼 2019/02/05 16:28

補足 2019/02/05 13:35

関連するQ&A

エクセルをVBAでOUTLOOKで送信したい（再）

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

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

Excel VBAで検索（Win2000 Excel2000）

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

ＶＢＡでMP3を鳴らしたい

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

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

vba boolean変数を開放する方法

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

BASP21を使ってファイル添付メールを送信したい

エクセルでセルの値がTRUEかFALSEか判定

エクセル VBA シート保存ボタン

アクセスの印刷ＶＢＡを教えて下さい

エクセル シートのみ 保存

エクセルVBAでPDFを1枚目のみ印刷したい

Excel VBAで新たな保存先のパスの取得方法は？

VBAでExcelファイルのPDF自動化

エクセルでマクロを使った保存の件で？

VBAで2つのBOOKのセル範囲を比較

注目のQ&A

カテゴリ 一覧

専門家に質問してみよう 専門家登録

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

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

エクセル　VBA　シート保存ボタン

エクセル　シートのみ　保存

カテゴリ
一覧

専門家に質問してみよう
専門家登録