『VBAでフォルダ名を令和に』（ララダス）
VBAでのファイル操作で自身も含め同じフォルダ内の全てのファイルをコピーしたいのですが一つ問題がありまして、コードを書くと
Dim リスト範囲, 持出, 発注者, 現場, 担当者, 金額, 日付, フォルダ, パス, コピー先 As String
中略
日付 = Format(持出, "ggge年m月")
こんな感じですがExcel2003で作ってるのでこのままだと"平成36年6月"となってしまうので
日付 = Format(持出, "yyyy年m月")
として西暦で表示するようにしました。
ほんとは、"6年6月"となるようにしたいのですがやり方が分かりません。
どうしたらいいでしょうか?
ちなみにExcelのバージョンを上げればいいと思われるかもしれませんが社員それぞれのPCが古く新しいバージョンで作っても動作しないと思うのでしかたがないのです。
＜ 使用 アプリ：Excel2003、使用 OS：Windows10 ＞
Year関数で西暦を取得し、それから2018引けば令和年 同様にMonth関数で月を取得し、文字列で連結すれば 希望通りになります。
（tkit） 2024/04/10(水) 16:19:01
Dim リスト範囲, 持出, 発注者, 現場, 担当者, 金額, 日付, フォルダ, パス, コピー先 As String
■２
上記と関連しますが、↓が思惑通りの動作をするということは「持出」はDATE型のハズです。
Format(持出, "ggge年m月")
■３
既にアドバイスがありますが、より厳密にいえば「2019/5/1」以降であれば令和です。
さらにどちらかと言えば「令和1年」という言い方ではなく「令和元年」という言い方になろうかとおもいます。
■４
ということを踏まえますと、例えば↓のようなユーザー定義関数を作ればよいのではないかと思います。
Function 俺式関数(持出 As Date) As String
If 持出 >= #5/1/2019# Then
俺式関数 = Replace("令和" & Year(持出) - 2018 & "年", "令和1年", "令和元年") & Format(持出, "m月")
Else
俺式関数 = Format(持出, "ggge年m月")
End If
End Function
（もこな２ ） 2024/04/10(水) 18:13:03
Cells(2, 9) = 持出
Cells(3, 8) = 発注者
Cells(4, 8) = 現場
Cells(5, 8) = 担当者
Cells(6, 8) = 金額
日付 = Format(持出, "ggge年m月")
フォルダ = 日付 & 現場
と"6年6月熊本"いうようなファイルセットを作りたいのです。
tkitさんの提案はもちろん最初に試しました。その結果として、
"非表示モジュール 初期設定内でコンパイルエラーが発生しました。"
というエラーが出て止まりました。
また、もこな２さんのユーザー定義関数は素晴らしい思い組み込んでみましたが、やはりコンパイルエラーが表示されました。
なので"日"という変数に#年#月という数字だけ(文字列でも可)を記憶させる方法を教えてください。
（ララダス） 2024/04/11(木) 09:34:45
>tkitさんの提案はもちろん最初に試しました。その結果として、 >"非表示モジュール 初期設定内でコンパイルエラーが発生しました。" >というエラーが出て止まりました。
コンパイルエラーとは、構文エラーのことです。 試したコードの提示が無いと分かりません。
（tkit） 2024/04/11(木) 09:56:29
なんか不可解な展開だなぁ。
一体、"持出"に何が入っているのですか？ その実体値を教えてください。
（半平太） 2024/04/11(木) 09:58:50
それは、（このトピックを見てから）実装したものが原因ではないのでは？
https://answers.microsoft.com/ja-jp/msoffice/forum/all/%E3%83%9E%E3%82%AF%E3%83%AD%E3%81%8C%E5%8B%95/c2675e37-cebe-4226-a820-724b0e5c612a
■６
余談として書こうかと思ってやめてましたが、そもそも論として↓の話がどうつながってるのか理解できていません。
【やりたいこと】
VBAでのファイル操作で自身も含め同じフォルダ内の全てのファイルをコピーしたい
【困ってること】
2019/5/1以降をFormat関数を使って変換すると"平成○年×月"になってしまう
てっきりフォルダ名を月ごとに作成していてファイルのタイムスタンプから振り分けたいとかそういう話かなと思いましたが違いましたかね？
■７
＞実は～"6年6月熊本"いうようなファイルセットを作りたいのです。
理解できません。
少なくとも↓左右逆じゃないですか？
Cells(4, 8) = 現場 Cells(2, 9) = 持出
また、【ファイルセット】と表現されているものは、一般的には【フォルダ】とか【ディレクトリ】と呼ばれているものではないでしょうか？
こちらには、あなたの画面や頭の中は見えませんので、現状ではこれ以上のアドバイスは困難です。
（もこな２ ） 2024/04/11(木) 10:24:39
Option Explicit
Dim i As Integer
Dim 行 As Long
Dim リスト範囲, 持出, 発注者, 現場, 担当者, 金額, 日付, フォルダ, パス, コピー先 As String
Dim ファイル名 As Object
Const タイトル As String = "経費明細書入力支援システム"
'=========================================================================================
Private Sub UserForm_Initialize() 'ユーザーフォームを初期化する
Application.Visible = False
Application.ScreenUpdating = False
ActiveSheet.Unprotect "8731"
Worksheets(2).Activate
TextBox3.Value = Year(Date)
TextBox4.Value = Month(Date)
TextBox5.Value = Day(Date)
行 = Range("D201").End(xlUp).Row 'リストの下端行を取得
リスト範囲 = "D1:D" & 行 'リストのソース範囲を表す文字列を作成
ComboBox1.RowSource = リスト範囲 'コンボボックスのリストのソース範囲を設定
ListBox1.RowSource = "E1:E12" 'リストボックスのリストのソース範囲を設定
Worksheets(1).Activate
パス = ThisWorkbook.Path
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Activate() 'ユーザーフォームがアクティブになった
ComboBox1.DropDown '発注者のリストを表示する
End Sub
Private Sub UserForm_terminate() 'ユーザーフォームが終了した
Application.Visible = True
Worksheets("入力").Activate
ActiveSheet.Protect Password:="8731", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowDeletingRows:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Unload 初期設定 'ユーザーフォームを削除する
End Sub
'-----------------------------------------------------------------------------------------
Private Sub UserForm_Deactivate() 'ユーザーフォームがアクティブでなくなった
Worksheets("入力").Activate
End Sub
'=========================================================================================
Private Sub ComboBox1_Click() '発注者のリストがクリックされた
TextBox1.SetFocus '現場名テキストボックスにフォーカスを移す
End Sub
'=========================================================================================
Private Sub listBox1_Click() '担当者のリストがクリックされた
TextBox2.SetFocus '現場名テキストボックスにフォーカスを移す
End Sub
'=========================================================================================
Private Sub CommandButton1_Click() '確定ボタンがクリックされた
持出 = TextBox3.Value & "/" & TextBox4.Value & "/" & TextBox5.Value
発注者 = ComboBox1.Value
現場 = TextBox1.Value
担当者 = ListBox1.Value
金額 = TextBox2.Value
If 持出 <> "" And 発注者 <> "" And 現場 <> "" And 担当者 <> "" And 金額 <> "" Then '全て入力されていれば
'-----------------------------------------------'セルに値をセットする
初期設定.Hide 'ユーザーフォームを隠す
Application.ScreenUpdating = False
If CheckBox1.Value = False Then
Application.DisplayAlerts = False
Range("リストの範囲").ClearContents
End If
Range("明細の範囲").ClearContents
Cells(2, 9) = 持出
Cells(3, 8) = 発注者
Cells(4, 8) = 現場
Cells(5, 8) = 担当者
Cells(6, 8) = 金額
日付 = Format(持出, "ggge年m月")
Else
MsgBox "記入もれがあります、確認してください", , タイトル
Exit Sub
On Error Resume Next
End If
フォルダ = 日付 & 現場
ChDrive パス
ChDir パス
ChDir ".."
MkDir フォルダ
ChDir フォルダ
コピー先 = CurDir
Set ファイル名 = CreateObject("Scripting.FileSystemObject")
ファイル名.CopyFile パス & "\*.*", コピー先
ActiveWorkbook.SaveAs _
Filename:="経費清算書.xls", CreateBackup:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowDeletingRows:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Stop
Workbooks.Open Filename:="工事日報.xls"
Worksheets("新型日報").Visible = True
For i = Worksheets.Count To 2 Step -1
Sheets(i).Select
ActiveWindow.SelectedSheets.Delete
Next
Sheets(1).Copy After:=Sheets(1)
Sheets(2).Name = Month((持出) - 2018) & "月" & Day(持出) & "日"
Range("F6").Value = 担当者
Range("D2").Value = 発注者
Range("W3").Value = 現場
Range("Z2").Value = Year(持出) - 2018
Range("AB2").Value = Month(持出)
Range("AD2").Value = Day(持出)
Worksheets("新型日報").Visible = False
ActiveWorkbook.Save
ActiveWorkbook.Close
UserForm_terminate
End Sub
これで何かわかりますか?
（ララダス） 2024/04/11(木) 10:41:01
コンパイルエラー時に、エラー部分がハイライトになるはずですが、 Year、Month、Day関数のところでしたか？
違っていたら、令和の年に変換には関係ありません。 （tkit） 2024/04/11(木) 11:59:21
■９
それはそれとして、ざっと眺めるに、例えば↓のようになればよいわけですよね？
Sub 研究用()
MkDir "C:\Work\" & 俺式関数(DateValue("2024/4/11")) & "熊本"
End Sub
----------------------------------------------------------------------------
Function 俺式関数(持出 As Date) As String
If 持出 >= #5/1/2019# Then
俺式関数 = Replace("令和" & Year(持出) - 2018 & "年", "令和1年", "令和元年") & Format(持出, "m月")
Else
俺式関数 = Format(持出, "ggge年m月")
End If
End Function
まずは、新規のブックで上記コードを試して、思惑通りの動作をするのか確認するところから始めてみてはいかがでしょうか？
■10
こちらもざっと眺めての感想ですが、
Active○○に依存するコードになっている
（該当フォルダが既にあって）MkDirステートメントが失敗したときのことを考えていない
そもそも、ファイルを移動する命令ではない ・フォルダを作成し、ブックをそこに保存するものである ・付随して（きちんと手当すれば）必要がないのに、カレントドライブ、カレントディレクトリの変更を行っている
インデントがやや適当で見づらい
というところが気になりました。
「Excel2003」ということですが、改善できそうな部分はそれなりにあると思いますので、余力があれば思い切ってコードを作り直すのも1つの手であるように思います。
（もこな２ ） 2024/04/11(木) 15:03:31
Private Sub CommandButton1_Click()
Dim buf As Variant
Dim 持出 As Date ''モジュールレベルから変更
Dim フォルダパス As String
For Each buf In Array("TextBox1", "TextBox2", "TextBox3", "TextBox4", "TextBox5", "ComboBox1", "ListBox1")
If Me.Controls(buf).Value = "" Then
MsgBox "記入もれがあります、確認してください", , タイトル
Exit Sub
End If
Next
持出 = DateValue(TextBox3.Value & "/" & TextBox4.Value & "/" & TextBox5.Value)
フォルダパス = ThisWorkbook.Path & "\" & 俺式関数(DateValue("2024/4/11")) & TextBox1.Value
初期設定.Hide
Application.ScreenUpdating = False
If CheckBox1.Value = False Then
Application.DisplayAlerts = False '←ココに記述する必要性が不明
Range("リストの範囲").ClearContents
End If
Range("明細の範囲").ClearContents
With ActiveSheet
.Cells(2, 9).Value = 持出
.Cells(3, 8).Value = ComboBox1.Value
.Cells(4, 8).Value = TextBox1.Value
.Cells(5, 8).Value = ListBox1.Value
.Cells(6, 8).Value = TextBox2.Value
End With
If Dir(フォルダパス, vbDirectory) = "" Then
MkDir フォルダパス
End If
ActiveWorkbook.SaveAs Filename:=フォルダパス & "\経費清算書.xls", CreateBackup:=False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowDeletingRows:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Stop
With Workbooks.Open(Filename:="工事日報.xls") '←こちらもパスをフォルダを指定することを推奨
.Worksheets("新型日報").Visible = True
Application.DisplayAlerts = False '←記述するならココではないか
For i = .Worksheets.Count To 2 Step -1
.Sheets(i).Delete
Next i
Application.DisplayAlerts = False
.Sheets(1).Copy After:=.Sheets(1)
With .Sheets(2)
.Name = Month((持出) - 2018) & "月" & Day(持出) & "日" '←月本当にこれでいいのか？
.Range("F6").Value = ListBox1.Value
.Range("D2").Value = ComboBox1.Value
.Range("W3").Value = TextBox1.Value
.Range("Z2").Value = Year(持出) - 2018
.Range("AB2").Value = Month(持出)
.Range("AD2").Value = Day(持出)
End With
.Worksheets("新型日報").Visible = False
.Save
.Close
End With
UserForm_terminate
End Sub
（もこな２ ） 2024/04/12(金) 09:19:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.