- ベストアンサー
エクセルのマクロを利用して
マクロ初心者でです。 いろんなサイトから引用させて頂き次のようなマクロを作成しました。 実行すると、日付と担当者氏名(A1)がファイル名となるものです。 そこで教えて頂きたいのですが、実行すると保存先がマイドキュメントに なるのですが、これを例えば「C:\日報」というフォルダが指定されるようにしたいのですが、 自分なりに、いろいろ試したのですが全くできません。 宜しくお願い致します。 Sub 名前をつけて保存() Dim SaveFileName As String, re As Variant With Sheets("sheet1").Range("A1") If .Value = "" Then MsgBox "名前が入力されていません", vbExclamation Exit Sub Else SaveFileName = Format(Now, "yyyymmdd") & "_" & .Value End If End With re = Application.GetSaveAsFilename(SaveFileName) If re = False Then MsgBox "保存を中止しました", vbExclamation Else MsgBox "日報をを保存しました", vbInformation End If End Sub
- tomo5000
- お礼率100% (3/3)
- その他MS Office製品
- 回答数3
- ありがとう数4
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
先頭に ChDir "C:\日報\" を入れてみてください。 でも、お書きのコードだけでは保存されませんよ。（ご存知とは思いますが） もし、アクティブなBOOKを名前を付けて保存するのなら Sub 名前をつけて保存02() With Sheets("sheet1").Range("A1") If .Value = "" Then MsgBox "名前が入力されていません", vbExclamation Exit Sub Else ActiveWorkbook.SaveAs Filename:= _ "C:日報\" & Format(Now, "yyyymmdd") & "_" & .Value & ".xls", FileFormat:=xlNormal End If End With End Sub
その他の回答 (2)
- knmrstkt
- ベストアンサー率31% (10/32)
ChDir "C:\日報" です。 ドライブの変更は ChDriveを使用
お礼
敏速な対応ありがとうございます。 やっぱりChDirで指定してするのですよね・・・。 試してみたつもりだったのですが・・・。 文節を間違えたのかな？ 参考になりました。 ありがとうございます。
- m_and_dmp
- ベストアンサー率54% (974/1797)
FFileName=Format(Now, "yyyymmdd") & "_" & .Value ActiveWorkbook.SaveAs Filename:="C:\日報\FFileName", _ FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False 、で良いのではないかと。FFileNameとしたのは、FileNameが、エクセルの予約語になっている恐れがあるため。
お礼
俊敏な対応ありがとうございます。 もしかするとベストなマクロなのかも知れませんが、 マクロ初心者のため、ドウ付け加えれば良いのか・・・。 デバッグになってしまいます。 参考にさせて頂きます。 本当にありがとうございます。
関連するQ&A
- エクセル・名前を付けて保存するマクロ 不要な文字を消す方法
お世話になります。 エクセルで「名前をつけて保存」のマクロを作って使用していますが、 一部、改造したいところがあります。 B20セルの文字が自動でファイル名になるようにしています。 「件名：●×商店納品見積書_20090125_1326」という感じなのですが、 最初の「件名：」という文字が不要で、毎回手動で消しています。 しかし、この文字を最初から消しておくわけにはいかず、 マクロ実行時のみ「件名：」が消えるようにしたいのです。 よい方法はありますか？ どうぞよろしくお願いします。 Sub ブック保存() Dim SaveFileName As String, re As Variant, WSH As Variant, Path As String Set WSH = CreateObject("WScript.Shell") Path = WSH.SpecialFolders("Desktop") & "\" With Sheets("見積書").Range("B20") If .Value = "" Then MsgBox "店舗名が入力されていません", vbExclamation Exit Sub Else SaveFileName = Path & .Value & "_" & Format(Now, "yyyymmdd_hhmm") End If End With Set WSH = Nothing re = Application.GetSaveAsFilename(SaveFileName) If re = False Then MsgBox "保存中止", vbExclamation Else ActiveWorkbook.SaveAs SaveFileName MsgBox "保存OK", vbInformation End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ 初心者です
エクセルマクロ初心者です。 以下の２つの Private Sub Worksheet_Change(ByVal Target As Range)を１つのシートで実行させたいのですが、 当方、初心者なので組み合わせ方が分かりません。 よろしくお願いします。 ===No1=== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target = StrConv(Target, vbUpperCase) Application.EnableEvents = True End Sub ===No2=== Private Sub Worksheet_Change(ByVal Target As Range) Dim Ans As Integer If Target.Count = 1 Then Ans = MsgBox("コピーは禁止!!", vbCritical) MsgBox "データを消去します。" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If If Target.Count = 1 Then Exit Sub Else MsgBox “複数セルのコピー禁止！" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End Sub ------------ 上記の２つを１つのシートで動作させたいのですが、うまくいきません。 単体では、動作します。
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロについて
Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア～ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか？できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub
- 締切済み
- オフィス系ソフト
- 指定した範囲で0の行を削除するマクロ
以下のコードで7列目が0の行を削除するマクロを作ったのですが、 13行目以降を削除するように指定できますでしょうか？ 1-12行は別のシートに数式を入れているため、削除したくないのですが、 うまくいきません。よろしくお願いいたします。 Sub 行削除() Dim Rw As Long Dim Cnt As Long Application.ScreenUpdating = False For Rw = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1 With Cells(Rw, 7) If .Value = 0 Then .EntireRow.Delete Cnt = Cnt + 1 End If End With Next If Cnt = 0 Then MsgBox "削除対象行は、見つかりません。", vbExclamation Else MsgBox Cnt & " 件見つかり行を削除しました。", vbInformation End If End Sub
- ベストアンサー
- その他MS Office製品
- 下記のマクロをもっと早くするには？
下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロを動かすと、大体３秒に１つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか？ また、エクセルの他の設定で、マクロを早くできたりしますか？ よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub
- 締切済み
- Visual Basic
- EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。
(1)EXCELファイルでマクロを作成しました。 (実際はここである人の知恵をお借りして作ったものですが…) しかし、(2)EXCELファイルで(1)EXCEL作成マクロが実行できません。 どのような処理をすれば、どのPCでも、どのファイルでも実行できるようなマクロに出来るのでしょうか？？ 以下にそのマクロを示します。 ↓↓↓ Sub 文字置換() '半角カタカナを全角に、全角英数を半角にするマクロ (Excel編） Dim rng As Range Dim Re As Object Dim myPat As String Dim c As Range Dim Matches As Object Dim Match As Object Dim Str1 As String Dim Str2 As String Dim buf As String Dim t As Long On Error Resume Next Set rng = ActiveSheet.UsedRange.SpecialCells _ (xlCellTypeConstants, xlTextValues) On Error GoTo 0 If rng Is Nothing Then MsgBox "変換する対象が見当たりません。", 48 Exit Sub End If '全角側 --- 半角側 (！-／ を加えれば記号も半角) myPat = "([\uFF66-\uFF9F]*)([！-｝]*)" '正規表現のパターン Set Re = CreateObject("VBScript.RegExp") Application.ScreenUpdating = False With Re .Global = True .IgnoreCase = True .Pattern = myPat For Each c In rng.Cells Set Matches = .Execute(c.Value) If Matches.Count > 0 Then buf = c.Value For Each Match In Matches If Len(Match.Value) > 0 Then Str1 = StrConv(Match.SubMatches(0), vbWide) If Str1 <> "" Then '0 =vbBinaryCompare buf = Replace(buf, Match.SubMatches(0), Str1, , , 0) End If Str2 = StrConv(Match.SubMatches(1), vbNarrow) If Str2 <> "" Then buf = Replace(buf, Match.SubMatches(1), Str2, , , 0) End If End If Str1 = "": Str2 = "" Next Match If buf <> c.Value Then c.Value = buf t = t + 1 End If End If Next c End With Set Re = Nothing Application.ScreenUpdating = True If t > 0 Then MsgBox t & "個のセルを変換しました。", 64 End If End Sub 出来れば、置換した文字数をメッセージBOXに表示したいです。
- 締切済み
- オフィス系ソフト
- エクセルマクロの保存
エクセルのマクロについて教えてください。エクセル２０１０でセルをダブルクリックすると、同一フォルダ内のＰＤＦファイルデータを表示するというマクロを作ってもらったのですが、保存する際に「次の機能はマクロ無しのブックに保存できません・ＶＢプロジェクト～」と表示されExcelマクロ有効ブック（拡張しｘｌｓｍ）に替えて保存するとマクロのコード自体は残っているのですが、Not find fileと出てしまいます。また最初からExcelマクロ有効ブックでコードを入力しても同様の結果になります。このような場合どのように保存すればいいのでしょうか？ ちなみにコードは下記のようになります。 'Option Explicit 'Private Const pdfPATH As String = "D:\5678\" Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True If Not Target.Value Like "*.pdf" Then Exit Sub If Dir(pdfPATH & Target.Value) = "" Then MsgBox "File Not Found": Exit Sub With CreateObject("Wscript.Shell") .Run "" & pdfPATH & Target.Value & "", 3 End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ 教えてください。
sheet１に （a1=No. b1=月日 C1=項目 d1=収入 e1=支出 f1=摘要 G1=店名）項目を作りそれらをユーザーフォームを作り入力したいです。 この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。 本当に良いですか? ", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロ検索（ctr+Fと同等の機能）
初めまして。検索に関してわからないので宜しく御願いします。 エクセル付属の検索と同じ事をマクロで実行したいと思っています。 具体的には、”次を検索”という事をしたいです。 付属の検索でやらないのは、その前に検索範囲を自動で指定したいためです。 わかる方、いらした教えて下さい。 よろしく御願いします。一応、自分で作った物をはらせて頂きます。 Sub 検索() If 選択 = 1 Then 検索範囲 = "C:C" Else 検索範囲 = "D:D" End If With Worksheets("sheet1") Set FoundCell = Columns(検索範囲).Find(検索キー) If FoundCell Is Nothing Then MsgBox 検索キー & "は見つかりません。", vbExclamation Else FoundCell.Select End If End With End Sub 検索キーはフォームで取得しています 宜しく御願いします
- ベストアンサー
- オフィス系ソフト
- excel マクロでの特殊文字入力方法
マクロで特殊文字入力は出来ないのでしょうか？ やりたい内容は、セルをダブルクリックした時に✓を表示させたいのです。 セルをダブルクリックした時に○を表示するマクロが、下記の通りである時、 ○の代わりに✓を表示させたいのですが、VBAで○の所に✓で書き換えると ?と表示されてしまいます。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) With Target If .Value = "○" Then .Value = "" Else .Value = "○" End If End With End Sub
- ベストアンサー
- オフィス系ソフト
お礼
早速の対応ありがとうございます。 まさにこの動きです。 保存のときにワンアクションあるのも気に入らなかったんです。 自分で調べることは大切なことですが、悩み煮詰めてどうしてものときは またお世話になるかも知れませんが宜しくお願い致します。