• ベストアンサー

音楽ファイルが再生できない(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 & "がありません。", 」 とならないのでファイルは見つかっているのだと思います。 何か原因がわかる方よろしくお願いします。

  • kuhffd
  • お礼率97% (246/252)

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

  • ベストアンサー
  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.8

ありゃ。本当だ。 VistaだとWSHで起動する#3の方法使えなくなったんですね。 管理者権限でしょうかね。 APIだと不都合があるんですか？

kuhffd
質問者

お礼

APIでも全然不都合ないです。 ただAPIというとなんだか敷居が高い感じがするので できれば普通のマクロ行ないたかったのですが できなかったため疑問になり質問しました。 何度もありがとうございます。

その他の回答 (7)

  • xls88
  • ベストアンサー率56% (669/1189)
回答No.7

mplay32.exeとは http://art2006salt.blog60.fc2.com/blog-entry-571.html

kuhffd
質問者

お礼

ありがとうございます。

  • xls88
  • ベストアンサー率56% (669/1189)
回答No.6

mplay32.exe が見つからないということではないでしょうか。 mplay32.exeがあるなら、フルパスで記述してみればどうでしょうか。 参考までにVistaでは、下記で鳴りました。 C:\Program Files\Windows Media Player\wmplayer.exe

kuhffd
質問者

お礼

Media Playerの中にmplay32.exeはないですし 検索をかけてもでてきませんでした。 とうことはやはりないのですね。 ありがとうございます。

  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.5

音楽流れないですか。おかしいですね。 再生が始まらない感じですか？ そのファイルは普通にダブルクリックしたときは再生されるのでしょうか？

kuhffd
質問者

お礼

たびたびすいません。 APIの方法なら再生できるし、ダブルクリックでも再生は可能です。

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.4

Windowsでファイル名で使えない文字に/が入っているのでは。 質問の例は全角/なのかな。 APIでは動くとなると？？ http://blogs.dion.ne.jp/tmikami/archives/6570815.html http://www.sharp.co.jp/support/mebius/tips/tips-zz16.htm http://beefway.hp.infoseek.co.jp/prog/filename.html

kuhffd
質問者

お礼

うーん これらの文字は入れてないですね。。。 ありがとうございます。

  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.3

見る限り別にmplay32で再生する必要はなさそうですね。 WSHを使って、関連付けられたアプリケーションで開くこともできますよ。 Dim WSH As Variant Set WSH = CreateObject("Wscript.Shell") 　　'バックグラウンドで流すイメージなら、vbNormalFocuをvbMinimizedNoFocusする WSH.Run "rundll32.exe url.dll, FileProtocolHandler " & _ SoundFile, vbNormalFocus, False Set WSH = Nothing Exit Sub

kuhffd
質問者

お礼

いろいろな方法があるのですね！ ただWindows Media Playerは起動するのですが音楽が流れません。。。 もっと試してみます。ありがとうございます。

  • phoenix343
  • ベストアンサー率15% (296/1946)
回答No.2

| 結果は同じでした。 そうですか、、mplay32.exeがないのでは？ DOS窓を開き、 mplay32.exe <ファイル名> をじかに実行してみましょう。 'mplay32.exe' は、内部コマンドまたは外部コマンド、 操作可能なプログラムまたはバッチ ファイルとして認識されていません。 と出たらパスが通っていないか、mplay32.exe自身がないことが疑われますが、、

kuhffd
質問者

お礼

DOS窓ってコマンドプロンプトのことですよね？ やってみましたがおっしゃるとおり 'mplay32.exe' は、内部コマンドまたは外部コマンド、 操作可能なプログラムまたはバッチ ファイルとして認識されていません。 になりました。 'mplay32.exe' を検索をかけてみましたがヒットしませんでした。 ということはパソコンに入ってないと言うことですね。 再度ありがとうございます。

  • phoenix343
  • ベストアンサー率15% (296/1946)
回答No.1

"でかこいましょ Shell "mplay32.exe /play /close """ & SoundFile & """" 漢字や空白を含むファイル名だったときは " で囲むよね？ うまくいかなかったらごめん

kuhffd
質問者

お礼

うーん 結果は同じでした。 ありがとうございます。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

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

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

    ＶＢＡで音楽を鳴らしたいのですが、 ファイルを立ち上げて音楽を鳴らすプロシージャーを一度実行すると、 もう何度Ｆ５を押しても実行されません。 しかしファイルを開きなおすとまた実行できます。でも１回限りです。 コードはこちらです。 ------------------------------------------------------------ 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です。 ご回答よろしくお願いします。

  • (VBA)フォルダー内のファイルを自動で読み込む

    以下でターゲットフォルダーを指定して その中に存在する、テキストファイル(.txt)とMP3ファイル(.mp3)を 各1個ずつをそれぞれ読み込むようにしています。 'フォルダーを一覧から選択 (自由に選べること) MsgBox "ターゲットフォルダーを選択してください。", vbOKOnly + vbQuestion, "Making" With Application.FileDialog(msoFileDialogFolderPicker) With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then If Len(.SelectedItems(1)) = 3 Then ' c:\の場合とサブフォルダーの場合 TurgetFolder = .SelectedItems(1) Else TurgetFolder = .SelectedItems(1) & "\" End If End If End With 'TEXTファイル選択（ダイアログ） MsgBox "ターゲットになる" & vbCrLf & "テキストファイルを選択してください。", vbOKOnly + vbQuestion, "LIST" ChDir TurgetFolder TurgetTEXT = Application.GetOpenFilename("TEXTファイル(*.txt),*.txt") If VarType(TurgetTEXT) = vbBoolean Then MsgBox "選択がキャンセルされました" Else 'MsgBox TurgetFile & " が選択されました" End If 'Mp3サイズ読み込み() MsgBox "ターゲットMP3を選択してください。", vbOKOnly + vbQuestion, "MP3" TargetMP3 = Application.GetOpenFilename("MP3ファイル,*.mp3") 'MsgBox TargetMP3 Set fso = CreateObject("Scripting.FileSystemObject") Set SHell = CreateObject("Shell.Application") Set Folder = SHell.Namespace(fso.GetFile(TargetMP3).ParentFolder.Path) Target = fso.GetFile(TargetMP3).Name ----------------------------------------------- 今回、間違いが無くなるように フォルダー構造をターゲットフォルダーの中に テキスト及びMP3ファイルが一つずつしかない無い構造にしたので それぞれ別々に指定する必要なく ターゲットフォルダーを指定するとその中に存在する テキスト及びMP3ファイルを自動で指定（読み込む）ように改造したいのですが どのように改造すれば良いでしょうか　？

  • マクロ　検索できなかった検索値を表示したい

    C列を複数の検索値で検索して見つからなかった検索値が 一つでもあればその検索値をメッセージBOXに表示した上で どの検索値であっても同じ処理をしたいです。 全て検索できた場合は別の処理をしたいです。 今自力で出来るのは以下の記述ですが 同じ処理を6回も記述しておりメンテしにくいです。 また、記述順で最初に見つからなかった検索値だけしか 表示できない（それでも問題は無いです）という弱点もあります。 他に方法はありますでしょうか？ 配列関連は自力で作成出来ませんので他の方法にてアドバイスを いただけたらと思います。 C列には果物名がランダムに10,000行入力されています。 検索値を ・みかん ・りんご ・バナナ ・いちご ・すいか ・メロン としてそれらが全て存在するか検索し一つでも存在しない場合は その検索値をメッセージBOXに表示した上で どの検索値であっても同じ処理を行う。 全て検索できた場合は次の処理を行う。 Sub 実験2() Dim 範囲 Set 範囲 = ThisWorkbook.Worksheets("マスタ").Columns("C:C") Set rngFind = 範囲.Find("みかん") If rngFind Is Nothing Then MsgBox "ファイル【みかん】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("りんご") If rngFind Is Nothing Then MsgBox "ファイル【りんご】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("バナナ") If rngFind Is Nothing Then MsgBox "ファイル【バナナ】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("いちご") If rngFind Is Nothing Then MsgBox "ファイル【いちご】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("すいか") If rngFind Is Nothing Then MsgBox "ファイル【すいか】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("メロン") If rngFind Is Nothing Then MsgBox "ファイル【メロン】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select 'Sheets Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If 次の処理 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のオートフィルター実行時エラー

    エクセル 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 １か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。 宜しくお願いします！

  • エクセル 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 １か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。 宜しくお願いします！

  • beep音ではなく音楽（mp3ファイル）を鳴らしたい　（ＶＢＡ）

    Sub test() If ●● Then Else "○○.mp3"　’←10秒間ならしたい End If End Sub は可能でしょうか？ ご教授よろしくお願いします！！！

  • VBAでNAS上の共有フォルダ内のファイルに書き

    皆様、宜しくお願い致します。 私はVBA歴が浅く初心者に近いため、何卒ご教示の程お願い申し上げます。 「楽天Q&A」の諸先輩方のご教示のお陰で、今回「ユーザーフォーム.xlsm」のファイル名で VBAのユーザーフォームを作成し、「確定」ボタンをクリックすると、このユーザーフォームで 入力した内容を別のブックである「ご意見箱.xlsx」の「sheet1」に自動反映できるようになりました。 そこで、一点ご質問です。 ローカルディスク上では上記のように正常に動作できますが、この「ユーザーフォーム.xlsm」と 「ご意見箱.xlsx」の両ファイルをNAS上の「共有フォルダ」内に置いた環境下で、 NASと同一ネットワーク上の他のクライアント端末からも「ユーザーフォーム.xlsm」を開いて ユーザーフォームへの入力と、別のブックである「ご意見箱.xlsx」の「sheet1」に入力した内容を 自動反映させたいのですが、具体的にそのVBA構文をご教授頂けませんでしょうか・・・？ ネットワークパスは、\\IPアドレス\共有フォルダ\「ユーザーフォーム.xlsm」と \\IPアドレス\共有フォルダ\「ご意見箱.xlsx」でございます。 自分なりに方策を色々と調べてみたのですが、現在使っている「Dir」関数ではなく 「FileSystemObject」を用いれば、VBAの基本構文で記述できるようですが、 具体的にどのように記述したらいいのか詳細までは掴めませんでした・・・。 以下に現在、ローカルディスク上で問題なく動作しているVBA構文を参考までに掲載しておきます。 ★【ThisWorkbook】のVBA構文は、以下のようになっております。 'このExcelファイルを開いた時に行う処理 Private Sub Workbook_Open() On Error Resume Next Sheets("Sheet1").Activate '[ご意見入力フォームを開く]ボタンがあるシートを開く On Error GoTo 0 Application.Run "Opinion_Box_Open" End Sub ★【フォーム】（Opinion_Box）のVBA構文は、以下のようになっております。 'ユーザーフォームを開く Private Sub Opinion_Box_Open() Const myInformation As String _ = "現在は「ご意見箱」を利用する事ができません。" Dim PostRow As Long, buf As Variant _ , PostingOK As Boolean, Dummy(2) As String Call Confirm_posting_place( _ myInformation, PostingOK, Dummy(0), Dummy(1), Dummy(2)) If PostingOK Then Opinion_Box.Show End Sub 'ユーザーフォームに入力された投書データの転記先の有無を確認 '及び転記先Bookを開く事が可能な状況かどうかの確認 Sub Confirm_posting_place( _ ByVal myInformation As String, _ ByRef PostingOK As Boolean, _ ByRef StoragePath As String, _ ByRef PostFileName As String, _ ByRef PostSheetName As String) Dim buf As Variant StoragePath = "C:\Users\egmainlx\Desktop" '転記先のファイルが存在するフォルダーのパス PostFileName = "ご意見箱.xlsx" '転記先のファイルのファイル名 PostSheetName = "Sheet1" '転記先のファイル上の転記先のシートのシート名 buf = "" On Error Resume Next buf = Windows(PostFileName).Caption On Error GoTo 0 If buf = PostFileName Then PostingOK = Windows(PostFileName).Parent.Path = StoragePath Else PostingOK = True End If If Dir(StoragePath, vbDirectory) = "" Then PostingOK = False MsgBox "「ご意見箱」の投書内容の保存先のファイルがあるフォルダーとして" _ & "設定されているフォルダが見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「ご意見箱」を利用される方は、このトラブル内容を" _ & "「ご意見箱」の開発者（川添）へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先ファイル不明" ElseIf Dir(StoragePath & "\" & PostFileName) = "" Then PostingOK = False MsgBox "「ご意見箱」の投書内容の保存先のファイルとして設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "が所定のフォルダー内には見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「ご意見箱」を利用される方は、このトラブル内容を" _ & "「ご意見箱」の開発者（川添）へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先フォルダー不明" Else buf = Chr(0) On Error Resume Next buf = ExecuteExcel4Macro("'" & StoragePath _ & "\[" & PostFileName & "]" & PostSheetName & "'!R65536C256") On Error GoTo 0 If buf = Chr(0) Then PostingOK = False MsgBox "「ご意見箱」の投書内容の保存先として設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "というExcelBookの中には、投書内容の転記先として設定されている" _ & vbCrLf & vbCrLf & PostSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「ご意見箱」を利用される方は、このトラブル内容を" _ & "「ご意見箱」の開発者（川添）へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先シート不明" ElseIf Not PostingOK Then Windows(PostFileName).Activate MsgBox "「ご意見箱」の投書内容の保存先のExcel Bookとして設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "と同名の別Book(保存先フォルダが異なるBook)が開いているため、 " _ & myInformation & vbCrLf & vbCrLf _ & "「ご意見箱」を利用される場合には、現在開かれている" & vbCrLf & vbCrLf _ & Left(PostFileName, InStrRev(PostFileName, ".") - 1) & vbCrLf & vbCrLf & _ "というWindowのExcel Bookを閉じても問題がないか否かを確認し、" _ & "特に問題がない場合には、そのWindowのExcel Bookを閉じてから、" _ & "このフォームを開き直して下さい。" _ , vbExclamation, "保存先ファイルへのアクセス不能" End If End If End Sub 補足欄にも残りもう一つの「Module１」のVBA構文を掲載しておきます。 皆様、何卒ご教示の程、切にお願い申し上げます。（拝）

  • VBA

    Excel VBAでユーザーフォームを使ったアンケート入力フォームを作成しましたが、「確定」という名称のコマンドボタンをクリック実行時に別のExcelブック内の各セルにオプションボタンのキャプション（値）とテキストボックスの内容を反映（転記）させて、上書き保存させていく記述内容についてご教示頂けませんでしょうか。 具体的には、問(1)の回答は、別ブックのセルC5に反映させ、 問(2)の回答は、D5に反映、 問(3)の回答は、E5に反映、 問(4)の回答は、F5に反映、 問(5)の回答は、G5に反映、 問(6)の回答は、H5に反映、 その他のテキストは、I5に反映させる といった動作にさせるため、下記の内容で「標準モジュール」の構文と「フォーム」の構文を記述してみたのですが、このとおりどうさせるための具体的な構文が思い当たりません。 環境はExcel 2013です。どうにもならず困っているため、どうか宜しくお願い致します。 ～標準モジュールの構文～ 'ユーザーフォームに入力された転記先Book（アンケート回答結果.xlsx）の有無を確認 '及び転記先Book（アンケート回答結果.xlsxを開く事が可能な状況かどうかの確認 Sub Confirm_posting_place( _ ByVal myInformation As String, _ ByRef PostingOK As Boolean, _ ByRef StoragePath As String, _ ByRef PostFileName As String, _ ByRef PostSheetName As String) Dim buf As Variant StoragePath = "U:\Director" '転記先Bookファイルが存在するフォルダーのパス PostFileName = "アンケート回答結果.xlsx" '転記先Bookのファイル名 PostSheetName = "Sheet1" '転記先Bookのファイル上のワークシート名 buf = "" On Error Resume Next buf = Windows(PostFileName).Caption On Error GoTo 0 If buf = PostFileName Then PostingOK = Windows(PostFileName).Parent.Path = StoragePath Else PostingOK = True End If If Dir(StoragePath, vbDirectory) = "" Then PostingOK = False MsgBox "「アンケート回答入力フォーム」の投書内容の保存先のファイルがあるフォルダーとして" _ & "設定されているフォルダが見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「アンケート回答入力フォーム」を利用される方は、このトラブル内容を" _ & "「アンケート回答入力フォーム」の開発者へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先ファイル不明" ElseIf Dir(StoragePath & "\" & PostFileName) = "" Then PostingOK = False MsgBox "「アンケート回答入力フォーム」の投書内容の保存先のファイルとして設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "が所定のフォルダー内には見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「アンケート回答入力フォーム」を利用される方は、このトラブル内容を" _ & "「アンケート回答入力フォーム」の開発者へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先フォルダー不明" Else buf = Chr(0) On Error Resume Next buf = ExecuteExcel4Macro("'" & StoragePath _ & "\[" & PostFileName & "]" & PostSheetName & "'!R65536C256") On Error GoTo 0 If buf = Chr(0) Then PostingOK = False MsgBox "「アンケート回答入力フォーム」の投書内容の保存先として設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "というExcelBookの中には、投書内容の転記先として設定されている" _ & vbCrLf & vbCrLf & PostSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見当たらないため、" & myInformation _ & vbCrLf & vbCrLf & "「アンケート回答入力フォーム」を利用される方は、このトラブル内容を" _ & "「アンケート回答入力フォーム」の開発者へ報告して対応してもらうようにして下さい。" _ , vbExclamation, "《トラブル報告》保存先シート不明" ElseIf Not PostingOK Then Windows(PostFileName).Activate MsgBox "「アンケート回答入力フォーム」の投書内容の保存先のExcel Bookとして設定されている" _ & vbCrLf & vbCrLf & PostFileName & vbCrLf & vbCrLf & _ "と同名の別Book(保存先フォルダが異なるBook)が開いているため、 " _ & myInformation & vbCrLf & vbCrLf _ & "「アンケート回答入力フォーム」を利用される場合には、現在開かれている" & vbCrLf & vbCrLf _ & Left(PostFileName, InStrRev(PostFileName, ".") - 1) & vbCrLf & vbCrLf & _ "というWindowのExcel Bookを閉じても問題がないか否かを確認し、" _ & "特に問題がない場合には、そのWindowのExcel Bookを閉じてから、" _ & "このフォームを開き直して下さい。" _ , vbExclamation, "保存先ファイルへのアクセス不能" End If End If End Sub ～フォームの構文～ の内容については、文字数制限で収まりきれないため、この後すぐ私のユーザー名で新規質問の方で続きを書き込みいたしますので、そちらをご覧ください。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する