エクセルVBAで年を進める方法
- エクセルVBAを使用してファイル名の年を進める方法を説明します。
- 特定のVBAコードを実行するとファイル名から年を取得し、その年に1を加算することで進めることができます。
- しかし、現在のコードでは不正確な結果が得られています。正しい結果を得るためには、適切な修正が必要です。
- ベストアンサー
エクセルvbaブック名の年を進めたい
エクセル2013vbaです。 2014年という名前のファイルがあります。 vbaで、 Sub test() Dim myNew_path As String myNew_path = Format(DateAdd("yyyy", 1, Replace(ThisWorkbook.Name, "年.xlsm", "")), "yyyy") End Sub を実行すると、"1906/07/06"を取得しており、"1906"となってしまいます。 無理やりDateAddで110を足せば"2015"の取得はできますが、どうしてでしょうか？ どのように修正すればまともにDateAddに1を足して"2015"を取得できるのでしょうか？ すいませんが、お願いいたします。
- hinoki24
- お礼率61% (106/171)
- Excel（エクセル）
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
１年足したいなら2014+1で2015でしょう。 sub macro1() dim s as string s = left(thisworkbook.name, 4) + 1 & "年.xlsm" end sub ＞どうしてでしょうか？ どこかのセルに 2014 を記入、そのセルに日付の書式を取り付けてみると、エクセル的には2014は 1905/7/6 という日付と解釈している様子を確認することが出来ます。こういうのをエクセルの「シリアル値」と言います。 この日付に１年dateaddすると、ご質問の1906/07/06が出てきます。 言い換えると ＞まともにDateAddに1を足して"2015"を取得できるのでしょうか 2014じゃなく、まともに「2014年の日付」を整形した後にdateaddすればＯＫです。
関連するQ&A
- vbaで新規フォルダ作成時の名前の指定
「あいいうえお」フォルダの中に年が変わったら「2015年」という名前でフォルダの作成を行いたいのですが、下記のコードでは「あいうえお2015年」という名前のフォルダを作成してしまいます。フォルダの作成で、「あいうえお」を除いたものを作成するにはどう変えればよいでしょうか？ （12月のファイルで実行した時に例えば「2015年」フォルダを作成して、その中に「あいうえお2015-1月.xlsm]ファイルを作成します。同じ年なら「あいうえお11月.xlsm]などファイルのみを作成します。） お手数をおかけしますがどうぞよろしくお願いいたします。 Sub ブックコピー自動翌月分作成() Dim i As Integer Dim wb As Workbook Dim myDir_path As String, myNew_path As String 'フォルダパスとファイルパスを作成 myDir_path = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1) myNew_path = "あいうえお" & Format(DateAdd("m", 1, Replace(Replace(ThisWorkbook.Name, "あいうえお", ""), "月.xlsm", "")), "yyyy-m") & "月.xlsm" myDir_path = Left(myDir_path, InStrRev(myDir_path, "\")) & Left(myNew_path, 9) & "年\" 'フォルダの有無を確認、なければ作成 With CreateObject("Scripting.FileSystemObject") If Not .FolderExists(myDir_path) Then MkDir myDir_path 'MsgBox myDir_path & "を作成しました" 'MsgBox Left(myDir_path, InStrRev(myDir_path, "\")) & "に" & vbNewLine & MsgBox Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 12) & "に" & vbNewLine & _ Left(myNew_path, 9) & "年" & "フォルダを新たに作成しました" End If End With 'ファイルの有無を確認、なければ保存,あれば処理中止 If Dir(myDir_path & myNew_path) = "" Then ThisWorkbook.SaveCopyAs myDir_path & myNew_path MsgBox myNew_path & "のファイルを新たに作成しました" Else MsgBox "翌月分のファイルはすでに存在するので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If '新規作成したブックを開く,既に開いていれば処理中止 For Each wb In Workbooks If wb.Name = myNew_path Then MsgBox myNew_path & "は既に開いているので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If Next Workbooks.Open myDir_path & myNew_path Workbooks(myNew_path).Activate End Sub
- ベストアンサー
- Excel（エクセル）
- ExcelVBA一つ上までのフォルダ作成
ExcelVBA2007以上で質問です。 現在のファイルのあるフォルダは例えば「11月分」という名前になっています。 もうひとつ上は「2014年」というフォルダになっています。 コードを実行すると、翌月のフォルダとファイルを作成するようになっています。 現在11月なので、実行すると「12月分」というフォルダを作成して、「AAA2014-12」というファイルを作成します。さらにこれを実行して、例えば "D:\YM\Desktop\AAA\2015年\1月分"\AAA2015-1.xlsm のように2015年のフォルダを作成してさらにその中に1月分のフォルダを作成したいのですが、2014年フォルダの中に1月分フォルダが作成されるだけで、どうすればいいのか分かりません。 今の所、月のフォルダと、ファイル名は翌月取得が下記のコードで実現できています。 最後のコードに手を加える必要があると思いますが、どうすればよいでしょうか？ Sub AAA翌月ファイル作成() Dim myDir_path As String, myNew_path As String '現在ファイルがあるフォルダパスを取得 myDir_path = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1) '翌月分のファイル名を取得 myNew_path = "在庫数" & Format(DateAdd("m", 1, Replace(Replace(ThisWorkbook.Name, "AAA", ""), ".xlsm", "")), "yyyy-m") & ".xlsm" '翌月のファイルを保存するフォルダ名を取得 あとは、年が変わったら1年繰り上げたものを取得したい myDir_path = Left(myDir_path, InStrRev(myDir_path, "\")) & Format(DateAdd("m", 1, Replace(Replace(ThisWorkbook.Name, "AAA", ""), ".xlsm", "")), "m") & "月分\"
- ベストアンサー
- Excel（エクセル）
- エクセルVBAでブックを開くと処理が終わってしまう
VBA初心者なのですが、VBAでエクセルブックを開くとVBAの処理が終わってしまいます。理由がわからないのでアドバイスをお願いします。なお、止まってしまう箇所にコメントを入れプログラムを下記しました。また、4000字以上質問できないためプログラムの途中までしか書かれていません。そのため、余分な宣言が多数ありますが無視してください。よろしくお願いいたします。 Option Base 1 Sub 健康診断の郵送() Dim kyoNum() As String Dim b_name As String Dim a_name() As Variant Dim b_address As String Dim a_address() As Variant Dim mailNum() As Variant Dim place() As String Dim banchi() As String Dim ken() As String Dim Adr As String Dim AdrLen As Integer Dim i, j, k, cnt, l, m As Integer Dim ChrCode As Integer Dim cell As Range Dim Book1 As String Dim wb As Workbook Dim Book1_Path As String Dim flag As Boolean 'セルのクリア ThisWorkbook.ActiveSheet.Cells.ClearComments 'セルのプロパティを設定をする With ThisWorkbook.ActiveSheet.Columns("A:B") .ShrinkToFit = True .NumberFormatLocal = "@" .ColumnWidth = 45 End With 'カレントディレクトリのチェンジ(Windows2000以降) CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path '簡易名称Book1にする Book1 = "Book1.xlsx" 'パスを取得する Book1_Path = ThisWorkbook.Path & "\" & Book1 If Dir(Book1_Path) = "" Then MsgBox "Book1.xlsxファイルが存在しません。", vbExclamation End If '同名ブックのチェック For Each wb In Workbooks If wb.Name = Book1 Then MsgBox "健康診断の郵送.xlsmはBook1を開こうとしています" _ & vbCrLf & "Book1を閉じて再実行してください", vbExclamation Exit Sub End If Next wb Application.ScreenUpdating = False '画面の更新を止める Workbooks.Open Book1_Path '＊＊＊＊＊←ここで処理が終わってしまう＊＊＊＊＊ 'ブック名を指定して非表示 Application.Windows("Book1.xlsx").Visible = False '後方検索でBook1.xlsxの入力済みセルの行数と列数を取得 With Workbooks("Book1.xlsx").ActiveSheet.UsedRange Book1_MaxRow = .Find("*", , xlValues, , xlByRows, xlPrevious).Row - 2 'データ入力済み行数取得 End With Application.ScreenUpdating = True Workbooks("Book1.xlsx").Activate j = 1 ReDim kyoNum(Book1_MaxRow) ReDim a_name(Book1_MaxRow) ReDim a_address(Book1_MaxRow) ReDim mailNum(Book1_MaxRow) ReDim ken(Book1_MaxRow) ReDim place(Book1_MaxRow) ReDim banchi(Book1_MaxRow)
- 締切済み
- Visual Basic
- ExcelVBAで翌月のファイル名取得
例えば「2014-12月.xlsm」というファイルがあって、あるコードを実行すると「2015-1月.xlsm」などのように次の月のファイルを作成してくれるとします。下記はその一部ですが、もしファイル名を変えて、「削除したい2015-2月.xlsm」という名前にした時、、「削除したい2015-3月.xlsm」という名前をpathに入れるようにするにはどこを変えればできるでしょうか？ すいませんが、よろしくお願いします。 path = Format(DateAdd("m", 1, DateValue(Replace(ThisWorkbook.Name, "月.xlsm", "-1"))), "yyyy-m") & "月.xlsm"
- ベストアンサー
- Excel（エクセル）
- Excel ブックのリネームがうまくできません
windows10,microsoft365使用の超初心者です。 デスクトップにフォルダ「計算」があります。その中に令和２年度計算.xlsmとフォルダ「実績」があります。フォルダ実績の中に令和２年９月実績.xlsxがあります。 このファイルの名前を変えたくて、下記コードをみつけました。 実行するとダイアログボックスに、令和２年度計算.xlsmと入っています。このボックスのなかに令和２年９月実績.xlsxを表示するには、 コードをどう変えたらいいか教えていただきたいです。よろしくお願いします。 Sub File_Name() Dim Cur_Path As String 'ファイルのパス' Dim Cur_Name As String '元のファイル名' Dim New_Name As String '変更後のファイル名' 'ファイルのパス、ファイル名の読み込み' Cur_Path = ThisWorkbook.Path Cur_Name = ThisWorkbook.Name 'インプットボックスの表示とファイル名の変更' New_Name = InputBox(Prompt:="ファイル名を入力して下さい。", Default:=Cur_Name) '「キャンセルボタン」または「×ボタン」を押した場合' If New_Name = "" Then Exit Sub Else End If 'ファイルの別名保存して閉じて再度開く' ThisWorkbook.SaveAs Cur_Path & "\" & New_Name Workbooks.Open Cur_Path & "\" & New_Name 'ファイルの別名保存して閉じて再度開く' If Cur_Path & "\" & New_Name <> Cur_Path & "\" & Cur_Name Then Kill Cur_Path & "\" & Cur_Name Else End If End Sub
- ベストアンサー
- Visual Basic
- Excel2007で拡張子xlsmのブックを保存
Excel2007でマクロ作成の初心者です。 以下のコードを実行させると、月次24年5月.xlsm-4143というブックができてしまいます。 そして開くこともできません。 どうしたら、月次24年5月.xlsm というブックにできるのでしょうか。 Sub データの保存() Dim Path As String, WSH As Variant Set WSH = CreateObject("WScript.Shell") Path = WSH.SpecialFolders("Desktop") & "\常用\H24年データ\月次" '和暦の年月で編集する Path = Path & Format(Date, "ee年m月") & ".xlsm" & Excel.xlWorkbookNormal '存在しない場合のみ作成する If Dir(Path) = "" Then ThisWorkbook.SaveAs Path End If Set WSH = Nothing End Sub
- ベストアンサー
- Visual Basic
- 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 -------------------------------------------------------------------
- 締切済み
- Excel（エクセル）
- Excel VBA
外部からモジュールを読み込めるようにしました。 ーーーーーーーーーーーーーーーーーーーーー Sub moduleImport_All() 'インポートしたいファイルのあるフォルダを指定 Dim sImportPath As String sImportPath = "C:\VBA\module\" 'FileSystemObjectの作成 Dim oFso As Object Set oFso = CreateObject("Scripting.FileSystemObject") 'フォルダオブジェクトを取得 Dim oDir As Object Set oDir = oFso.GetFolder(sImportPath) 'ファイル名を順次取得 Dim fFile As Object For Each fFile In oDir.Files 'ファイルの拡張子を取得 Dim sExt As String sExt = oFso.GetExtensionName(fFile.Name) '拡張子からモジュールだけを取得、インポート Select Case LCase(sExt) Case "bas", "cls", "frm" '指定のモジュールをインポート ThisWorkbook.VBProject.VBComponents.Import sImportPath & fFile.Name End Select Next MsgBox "完了" End Sub ーーーーーーーーーーーーーーーーーーーーー しかし、上書きがなされない為、1,2,3とモジュールが増えてしまいます。 読込みたいフォルダ内のファイルと同じ名前であれば全て上書きするにはどのように修正したらよいでしょうか？
- 締切済み
- Visual Basic
- エクセルＶＢＡ
こんばんは。 いつも拝見しています。初歩的でしょうが私ではまだ 解決できません。ご指導いただきたく思います。 ユーザーフォームにテキストボックスとスピンボタンを設置し日付を 変更するようにしています。ユーザーフォームを開くと今日の日付に 変わってしまいます。Ｃ２とリンクしテキストボックスに先に値を 取得するにはどうしたらよいでしょうか。お願します。 Private Sub spnDate_SpinDown() Dim dtDate As Date dtDate = UserForm1.txtDate.Value UserForm1.txtDate.Value = Format(DateAdd("m", -1, dtDate), "yyyy/mm") End Sub Private Sub spnDate_SpinUp() Dim dtDate As Date dtDate = UserForm1.txtDate.Value UserForm1.txtDate.Value = Format(DateAdd("m", 1, dtDate), "yyyy/mm") End Sub Private Sub txtDate_Change() Range("c2") = txtDate.Value End Sub
- ベストアンサー
- Visual Basic
- 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 '-------------------------------------------------------------------
- ベストアンサー
- Excel（エクセル）
お礼
どうもありがとうございました。