VBAでMP3を鳴らす方法

前へ 次へ
このQ&Aのポイント
  • VBAでMP3を鳴らす方法がわからない
  • 実行時エラー53が発生してMP3ファイルが見つからない
  • ShellコマンドでMP3ファイルを再生する際にエラーが発生
回答を見る
  • ベストアンサー

ＶＢＡで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」の部分でエラーになるのでしょうか？ スペックは、エクセル２００７、ｗｉｎｄｏｗｓ７です。 ご回答よろしくお願いします。

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

  • ベストアンサー
  • nicotinism
  • ベストアンサー率70% (1019/1452)
回答No.4

まずは、当方の環境説明。 Windows7 64bit ,Office 2010 32bit Wmplayer.exe について 検索すると二つ見つかりました。イミディエイトウィンドウでの確認だけですが shell ("C:\Program Files\Windows Media Player\wmplayer.exe " & "C:\Windows\Media\tada.wav") shell ("C:\Program Files (x86)\Windows Media Player\wmplayer.exe " & "C:\Windows\Media\tada.wav") どちらでも、働きました。 /play /close オプションは有っても無駄なだけですので入れてません。 音楽ファイル名にスペースが含まれる場合は shell ("C:\Program Files\Windows Media Player\wmplayer.exe " & """C:\Users\Public\Music\Sample Music\Sleep Away.mp3""") のように。 APIを使用する場合。 標準でMP3ファイルが無いかなと探したら有りましてので・・。 以下をがばっと標準モジュールに貼り付けてみてください。 Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _ (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Sub PlaySound() 　　Dim SoundFile As String, rc As Long 　　SoundFile = "C:\Users\Public\Music\Sample Music\Sleep Away.mp3" '多分有るかと？ 　　 　　If Dir(SoundFile) = "" Then 　　　　MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation 　　　　Exit Sub 　　End If 　　SoundFile = Chr(34) & SoundFile & Chr(34) 'スペース対策 　　 　　rc = mciSendString("Open " & SoundFile, "", 0, 0) 　　rc = mciSendString("Play " & SoundFile, "", 0, 0) 　　'rc = mciSendString("Play " & SoundFile & " wait", "", 0, 0) 　　'↑演奏が終わるまで処理が返ってこないので没 　　'rc = mciSendString("Close " & SoundFile, "", 0, 0) 　　If rc <> 0 Then 　　　　MsgBox rc & " ？のエラーです" 　　End If End Sub Sub CloseSound() 　　Dim SoundFile As String, rc As Long 　　SoundFile = "C:\Users\Public\Music\Sample Music\Sleep Away.mp3" 　　 '　　If Dir(SoundFile) = "" Then '　　　　MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation '　　　　Exit Sub '　　End If 　　SoundFile = Chr(34) & SoundFile & Chr(34) 　　 '　　rc = mciSendString("Open " & SoundFile, "", 0, 0) '　　rc = mciSendString("Play " & SoundFile, "", 0, 0) 　　'rc = mciSendString("Play " & SoundFile & " wait", "", 0, 0) 　　'↑演奏が終わるまで処理が返ってこないので没 　　rc = mciSendString("Close " & SoundFile, "", 0, 0) End Sub これで、とりあえずは演奏・終了が出来ると思います。（要らないコメントは適当に） どうやって音楽ファイルPathをモジュールに渡すか・・は 考えてみてください。 とっても参考になったところ（私自身、APIは門外漢です）VB6の話ですけど。 http://homepage1.nifty.com/rucio/main/technique/teq_1.htm >エラーになりませんが、音楽も演奏されません は前回回答の田中氏の 「・・いきなりPlayしていたのが原因かも・・」だと思います。 蛇足。 Wmplayer.exe が自動的に消えてくれないなら、いっそのこと WorksheetにActiveX コントロールの、『Windows Media Player』を張り付けて WorkSheetのダブルクリックイベントなどに Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Me.WMP.URL = Target.Value Cancel = True End Sub とか・・でも。Target に音楽ファイルのフルパスがあると仮定。 ※WMPは当方で付けたオブジェクト名です。デフォルトだと、WindowsMediaPlayer1 になりました。

n8y6fgfd
質問者

お礼

お返事が遅くなってしまい申し訳ございません。 PlaySoundでできました！私のためにいろいろ調べていただいてうれしいです＾＾ ありがとうございました。

その他の回答 (3)

  • okormazd
  • ベストアンサー率50% (1224/2412)
回答No.3

鳴るはず。 パスが通っていないんじゃないか。 Shell "c:\program files\windows media player\wmplayer.exe /play /close " & SoundFile とでもしてみたらどうでしょう。

n8y6fgfd
質問者

お礼

「Shell "c:\program files\windows media player\wmplayer.exe /play /close " & SoundFile」 に変えてみたら、なんとか通りましたが、今度は、 「ファイルの再生中にWindowsMediaPlayerに問題が発生しました。」 と表示され、音楽が再生されません。 しかし、MP3ファイルをダブルクリックしすれば、問題なく再生できません。 せっかくお答えいただいたのにすいません。ありがとうございました。

  • nicotinism
  • ベストアンサー率70% (1019/1452)
回答No.2

Windows7 ではmplay32.exe は無くなりました。 wmplayer.exe しか残ってません。 wmplayer.exe では、/play /close のオプションは有りませんので 演奏が終了してもそのまま残ります。 WinXPの時は重宝してたんですけどねぇ。。 なので下記サイトをご参考に。 http://officetanaka.net/excel/vba/tips/tips22.htm

n8y6fgfd
質問者

お礼

私もhttp://officetanaka.net/excel/vba/tips/tips22.htmを見て、Sample1のコードを参考にしました。 Shell "wmplayer.exe /play /close " & SoundFile に変えてもダメなので、 ＵＲＬ先のSample2を試してみたのですが、 エラーになりませんが、音楽も演奏されません。 なぜでしょうか？ 再度ご回答いただければ幸いです。

  • okormazd
  • ベストアンサー率50% (1224/2412)
回答No.1

「の部分では問題ないので」 は、"C:\終了音.mp3"があるかどうかであって、"mplay32.exe "がなければ 「ファイルが見つかりません」になる。 "mplay32.exe "があるかどうかとパスが通っているのかどうかを確認したほうがいい。 XPにはあるが、7には"mplay32.exe "はなかったと思うが。 7は"wmplayer.exe"になっていないか。

n8y6fgfd
質問者

お礼

音楽ファイルはあるけどmplay32.exe がないのですね。 ファイルを検索したら、wmplayer.exeはありましたが、 Shell "wmplayer.exe /play /close " & SoundFile に変えてもエラーになってしまいました。。。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 音楽ファイルが再生できない(VBA)

    http://qa.nou-college.net/qa4877134.html の続きですが Sub Sample1() Dim SoundFile As String SoundFile = "C:\Users\Music\サザンオールスターズ／希望の轍.mp3" If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If Shell "mplay32.exe /play /close " & SoundFile End Sub を実行すると「ファイルが見つかりません」となります。 他のMP3ファイルでも同じです。 APIを使う方法なら成功しました。 「MsgBox SoundFile & vbCrLf & "がありません。", 」 とならないのでファイルは見つかっているのだと思います。 何か原因がわかる方よろしくお願いします。

  • ファイルを開いて１回しか再生されない

    ＶＢＡで音楽を鳴らしたいのですが、 ファイルを立ち上げて音楽を鳴らすプロシージャーを一度実行すると、 もう何度Ｆ５を押しても実行されません。 しかしファイルを開きなおすとまた実行できます。でも１回限りです。 コードはこちらです。 ------------------------------------------------------------ Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _ (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Sub PlaySound() Dim SoundFile As String, rc As Long SoundFile = "C:\【音楽】\test.mp3" If Dir(SoundFile) = "" Then MsgBox SoundFile & vbCrLf & "がありません。", vbExclamation Exit Sub End If SoundFile = Chr(34) & SoundFile & Chr(34) rc = mciSendString("Open " & SoundFile, "", 0, 0) rc = mciSendString("Play " & SoundFile, "", 0, 0) End Sub ------------------------------------------------------------ ２回目実行した際音楽が鳴らないからってファイルがありませんと表示されるわけでもないです。 当方の環境はＯＳＷＩＮ７、ＯＦＦＩＣＥ2007です。 ご回答よろしくお願いします。

  • ＶＢＡで音楽を再生させた後

    ＶＢＡで音楽を再生させた後、Windows Media Playerを消したいのですが、 手作業で×ボタンを押すしかないのでしょうか？ Sub 終了音を鳴らす() Dim SoundFile As String SoundFile = "C:\終了音.wav" Shell "c:\program files\windows media player\wmplayer.exe /play /close " & SoundFile End Sub で、音楽は鳴らせるのですが、添付画像のように Windows Media Playerは開いたままです。 音楽を鳴らした後に、Windows Media Playerも閉じる方法をご教授ください。 ご回答よろしくお願いします。

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

  • Excel VBA 引数が2個のマクロの呼び出し方

    ExcelのVBAで、 シート上のボタンがクリックされた時に呼び出す マクロ(プロシージャ)の引数が1個の時は、 コード1のようにできましたが、 引数が2個ある時は、コード2のように記述しても、 ボタンをクリックするとエラーになりますが、 【？】の部分をどのように記述すればよいのでしょうか。 (Windows10,Excel2010) -------------------コード1---------------------------------------- Sub test1() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 2 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call ボタン作成(row, wave_file_path) 　Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "'" 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub ------------------------------------------------------------------- -------------------コード2---------------------------------------- Sub test2() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 2 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call ボタン作成(row, wave_file_path) 　Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "," & row & "'" <==【？】 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String, ByVal row As Integer) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path 　ThisWorkbook.Worksheets("Sheet1").Cells(row, 4).Value = "再生済" 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

  • エクセル　ＶＢＡ　バッチが動かない。

    以下のＶＢＡを試行錯誤の末（未熟なもので・・） 作ってみました。 デスクトップ上のフォルダを確認にて、存在する場合はそのままバッチ実行、 存在しない場合はフォルダを作成してバッチ実行。 というものなのですが、フォルダが存在する場合はすんなり行くのですが、 存在しない場合、フォルダを作成した後、バッチ処理がされなくて 困っています。どこが悪いのでしょうか？ 是非ご教授お願いいたします。 ちなみにバッチはＸＣＯＰＹです。 Sub SET_Original() Dim strPATHNAME As String strPATHNAME = "C:\Documents and Settings\ユーザー\デスクトップ\フォルダ" If StrConv(strPATHNAME, vbUpperCase) = "FALSE" Then Exit Sub If Dir(strPATHNAME, vbDirectory) = "" Then MsgBox "フォルダは作成します。", vbExclamation MkDir "C:\Documents and Settings\ユーザー\デスクトップ\フォルダ" Exit Sub End If Dim str As Variant str = Shell("c:\Documents and Settings\ユーザー\デスクトップ\copy.bat") End Sub

  • Excel シートにボタンを作成するVBA

    ExcelシートのA列にWAVEファイルのフルパス名が書かれている状態で、 このWAVEファイルを再生するボタンをC列に作成するVBAを作りたいのですが、 ボタンが押されたときに実行されるプロシージャに引数がないときは、 コード1のようにすればできますが、 ボタンが押されたときに実行されるプロシージャに引数があるときは、 コード2のように記述してもエラーになりますが、 どのように記述すればよいのでしょうか。(Windows10,Excel2010) '-----------------コード1------------------------------------------ Sub test() 　Dim row As Integer 　Dim wave_file_path As String 　row = 1 　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　Call 再生ボタン作成(row, wave_file_path) End Sub Sub 再生ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "WAVE_PLAY" 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY() 　Dim wave_file_path As String 　wave_file_path = "Z:\Document\4_Data\CD_DVD_USB\USB_20200222\REC\JBP001\JBP00101.WAV" 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub '------------------------------------------------------------------- '-------------------コード2---------------------------------------- Sub test() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 100 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call 再生ボタン作成(row, wave_file_path) 　Next row End Sub Sub 再生ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "WAVE_PLAY " & wave_file_path ' <====　◆ここでエラーになります◆ 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub '-------------------------------------------------------------------

  • 忍者へFTP接続でVBAでファイルをアップロード

    忍者へFTP接続でVBAでファイルをアップロードしたいです。 http://officetanaka.net/excel/vba/tips/tips47.htm を参考に実践してるのですがうまくできません。 FFFTPを使っての手動でのアップロードは問題なく行えます。 ----------------------------------------------------------------- Sub Sample1() Dim FTP, rc As Long, Server As String, User As String, Pass As String Dim Target As String, Folder As String Set FTP = CreateObject("basp21.FTP") ''FTPオブジェクト Server = "ftp.xxxxx.com" ''ホストアドレス User = "toru_tanaka" ''ユーザー名 Pass = "password" ''パスワード Target = Application.GetOpenFilename() ''送信ファイル If Target = "False" Then Exit Sub Folder = "/" ''送信フォルダ rc = FTP.Connect(Server, User, Pass) If rc <> 0 Then MsgBox "FTP接続できませんでした。", vbCritical FTP.Close Exit Sub End If rc = FTP.PutFile(Target, Folder) If rc <> 1 Then MsgBox Dir(Target) & "を送信できませんでした。", vbCritical FTP.Close Exit Sub End If MsgBox Dir(Target) & "を送信しました。", vbInformation FTP.Close End Sub ----------------------------------------------------------------- の rc = FTP.Connect(Server, User, Pass) If rc <> 0 Then MsgBox "FTP接続できませんでした。", vbCritical FTP.Close Exit Sub End If これは通過できるのですが、 rc = FTP.PutFile(Target, Folder) If rc <> 1 Then MsgBox Dir(Target) & "を送信できませんでした。", vbCritical FTP.Close Exit Sub End If で0が返るようで、送信できませんでした。となります。 トップページの階層にアップしたい場合は Folder = "/" でいいんですよね？ Folder = "/" にしても Folder = ""にしても失敗します。 FFFTPのメッセージランを見ていると、 VBAで送信できなくても ----------------------------------------------------------------- >TYPE A 200 転送タイプを A にセットしました >PASV 227 Entering Passive Mode (***). ダウンロードのためにホスト *** (***) に接続しています. (TCP/IPv4) 接続しました. (TCP/IPv4) >MLSD 150 ASCIIモードのデータ接続をオープンします MLSD 226 転送が完了しました ファイル一覧の取得は正常終了しました. (821 Bytes) ----------------------------------------------------------------- が表示されます。 何が間違ってるのでしょうか？ ご教授よろしくお願いします。

  • エクセル VBAのオートフィルター実行時エラー

    エクセル VBAのオートフィルター実行時エラーについて教えて下さい VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」 が表示されるのですが、エラーの内容がわかりません。教えて下さい。 Sub 複数条件でのデータ抽出() Const OrigSheetName = "データベース" Const PasteSheetName = "検索＆抽出" Const ItemRow = 2 Const FirstColumn = "A" Const LastColumn = "CH" Const UnnecessaryColumns = "W:CD" Const SearchColumn1 = "CF" Const SearchColumn2 = "I" Const PasteCell = "A2" Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _ LastRow As Long, Region As Variant, Period(1, 1) As Variant, _ temp As Variant, i As Long, c As Range Period(0, 0) = "1905/1/1" Period(1, 0) = "9999/12/31" Period(0, 1) = "以降" Period(1, 1) = "以前" If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then MsgBox "元データが入力されているシートとして設定されている" _ & vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set OrigSheet = Sheets(OrigSheetName) If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then MsgBox "データの転記先のシートとして設定されている" _ & vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set PasteSheet = Sheets(PasteSheetName) With OrigSheet LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row With .Range(LastColumn & Rows.Count).End(xlUp) If LastRow > .Row Then LastRow = .Row End With If LastRow <= ItemRow Then GoTo label9 label1: Region = Application.InputBox("参加または不参加を入力！", SearchColumn2 & _ "列に入力されている区分（Ａ組またはＢ組）の中で、抽出条件を入力して下さい", _ , Type:=6) If Region = vbNullString Or Region = False Then temp = MsgBox("区分が入力されていません。" & vbCrLf _ & "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:区分の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "区分未入力") If temp = vbNo Then Exit Sub Else GoTo label1 End If End If For i = 0 To 1 label2: Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _ "列に入力されている日付" _ & "で抽出する期間を指定して下さい。", _ Period(i, 0), Type:=2) If Period(i, 0) = vbNullString Or Period(i, 0) = False Then temp = MsgBox("日付が入力されていません。" & vbCrLf _ & "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:日付の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "日付未入力") If temp = vbNo Then Exit Sub Else GoTo label2 End If End If If IsDate(Period(i, 0)) Then If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _ Then GoTo label3 End If temp = MsgBox("入力された値は日付として扱う事が出来ません。" _ & vbCrLf & "日付の入力をやり直して下さい。", _ vbOKOnly + vbExclamation, "入力値不適切") GoTo label2 label3: Period(i, 0) = DateValue(Period(i, 0)) Next i End With With Application .ScreenUpdating = False .Calculation = xlManual End With With OrigSheet .Columns(UnnecessaryColumns).Hidden = True With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow) .AutoFilter Field:=1, Criteria1:=Region .AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _ Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0) End With Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow) i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count End With If i > 1 Then With PasteSheet .Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear c.SpecialCells(xlCellTypeVisible).Copy With .Range(PasteCell) .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats End With End With End If With c.EntireColumn .AutoFilter .Hidden = False End With If i > 1 Then GoTo labelE label9: MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _ & "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i labelE: With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub １か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。 宜しくお願いします！

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する