ExcelのVBAであるフォルダの中にあるファイルに自動的に名前を付けたい

質問

お世話になっています

ExcelのVBAで、あるフォルダの中にあるファイルに自動的に名前を付けたいのですが、どうしてもうまくいきません

「HOZON」（C:\Documents and Settings\TANAKA\デスクトップ\HOZON）というフォルダの中に「A」「B」「C」という3つのファイルがあります
その中にはそれぞれ
「Aファイル」→「A-S1」、「A-S2」、「A-S3」（3枚のシート）
「Bファイル」→「B-S1」、「B-S2」（2枚のシート）
「Cファイル」→「C-S1」（1枚のシート）
というシートがあります

そして、それぞれのシートの「A1」のセルには
「A-S1」→100
「A-S2」→101
「A-S3」→102
「B-S1」→200
「B-S2」→201
「C-S1」→300
という数字が入っています

やりたいことは
VBAでそれぞれのファイルの名前を
「【100－102】A」
「【200－201】B」
「【300】C」
と変えたいのです
つまり、現在の名前に、シートに書かれている一番小さい数字から大きい数字までを"-"でつないだ文字を付加して名前を付けなおしたいのです

ThisWorkbook.SaveAs Filename:=
で名前を付けると思うのですが、書くファイルの名前の取得の仕方とシートに書いてあるセルからの数字と合わせてリネームする方法がどうしてもわかりません

すいませんが、ファイルの数が膨大なので、教えていただけると大変助かります
宜しくお願いします

回答No.2

kuma3f · ベストアンサー

ANo.1のkuma3fです。
補足ですが、私の勘違いでファイル名に"【"が使えないとしていましたが使えますのですみません。
先のコードの"#"を"【"に変えてください。
変更後の名前 = "#" & テーブル最大値 & "#" & 文字列
↓
変更後の名前 = "【" & テーブル最大値 & "】" & 文字列

変更後の名前 = "#" & テーブル最小値 & "-" & テーブル最大値 & "#" & 文字列
↓
変更後の名前 = "【" & テーブル最小値 & "-" & テーブル最大値 & "】" & 文字列

また、先のコードはシート名がAファイルが「A-S1」、Bファイルが「B-S1」のようにされていましたのでシート名にファイル名が含まれているものを対象にしています。
もし、ファイル名とシート名に関連性がないのでしたら先のコードの
「If シート名 Like 文字列 & "*" Then」と「End If」を削除してください。（削除することで全シートが対象になります）

For Each シート In Workbooks(対象ファイル).Sheets 'シート検索
シート.Activate
シート名 = ActiveWorkbook.ActiveSheet.Name
文字列 = Left(対象ファイル, Len(対象ファイル) - 4)
'If シート名 Like 文字列 & "*" Then　　　　　　　　　←削除してください
シート数 = シート数 + 1
テーブル(シート数) = Workbooks(対象ファイル).Sheets(シート名).Range("A1")
If テーブル最小値 > テーブル(シート数) Then
テーブル最小値 = テーブル(シート数)
End If
If テーブル最大値 < テーブル(シート数) Then
テーブル最大値 = テーブル(シート数)
End If
'End If　　　　　　　　　　　　　　　　　　　　　　　　　　　←削除してください
Next シート

お礼

あーわかりました
すごく助かりました
本当に本当にありがとうございました
長いコードをありがとうございます
大変勉強になりました

回答No.1

kuma3f

思われていることと違っていましたらすみませんが、次のコードを新規Ｂｏｏｋのマクロに貼り付けて、そのＢｏｏｋを変換したいファイルのあるフォルダーの中に自由な名前をつけて保存し、保存したＢｏｏｋを開いてそのマクロを実行してみてください。
既存のファイルを壊してはいけないので、必ず、コピーしたフォルダー内でテスト的に行ってみてください。

新規ＢｏｏＫを開く
　↓
メニューバーの「ツール」→「マクロ」→「マクロ」をクリック
　↓
マクロのダイアログが表示されたらマクロ名に自由に名前を入力してください。（例：変換）
　↓
名前を入力しましたら、「作成」をクリック
　↓
Microsoft Visual Basicの画面が開きますのでSub 変換()の下に次のコードをコピーして貼り付けてください。

'<定義>
Dim パス名, 当ファイル, 当ファイル名, 対象ファイル, 変更後の名前, シート名, 文字列 As String
Dim テーブル最小値, テーブル最大値, テーブル(256) As String
Dim ファイル数, シート数 As Long
Dim シート As Worksheet
'<処理>
Application.ScreenUpdating = False
パス名 = ActiveWorkbook.Path & "\"
当ファイル = ActiveWorkbook.Name
当ファイル名 = パス名 & 当ファイル
Sheets("sheet1").Cells.ClearContents
With Application.FileSearch 'ファイルの検索
.NewSearch
.LookIn = パス名
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute() > 0 Then
For ファイル数 = 1 To .FoundFiles.Count
If 当ファイル名 <> .FoundFiles(ファイル数) Then
Sheets("sheet1").Cells(ファイル数, 1) = .FoundFiles(ファイル数)
Workbooks.Open Filename:=.FoundFiles(ファイル数) 'ファイルのOPEN
対象ファイル = ActiveWorkbook.Name
シート数 = 0
テーブル最小値 = 999
テーブル最大値 = 0
For Each シート In Workbooks(対象ファイル).Sheets 'シート検索
シート.Activate
シート名 = ActiveWorkbook.ActiveSheet.Name
文字列 = Left(対象ファイル, Len(対象ファイル) - 4)
If シート名 Like 文字列 & "*" Then
シート数 = シート数 + 1
テーブル(シート数) = Workbooks(対象ファイル).Sheets(シート名).Range("A1")
If テーブル最小値 > テーブル(シート数) Then
テーブル最小値 = テーブル(シート数)
End If
If テーブル最大値 < テーブル(シート数) Then
テーブル最大値 = テーブル(シート数)
End If
End If
Next シート
If テーブル最小値 = テーブル最大値 Then
変更後の名前 = "#" & テーブル最大値 & "#" & 文字列
Else
変更後の名前 = "#" & テーブル最小値 & "-" & テーブル最大値 & "#" & 文字列
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=パス名 & 変更後の名前 & ".xls" '保存
Application.DisplayAlerts = True
ActiveWorkbook.Close False 'ファイルのCLOSE
End If
Next
End If
End With
Application.ScreenUpdating = True
MsgBox "変換が終了しました。"
'****コピー貼り付けはここまで ****

Microsoft Visual Basicの画面を×で閉じます
　↓
この新規Ｂｏｏｋを変換したいファイルのフォルダー内に名前をつけて保存します
　↓
保存したらこのＢｏｏｋを開く
　↓
Excel画面のメニューバーの「ツール」→「マクロ」→「マクロ」をクリック
　↓
先ほど名前を付けたマクロ（変換）を選択して「実行」をクリック
作成されると思います。

ファイル名に"【"が使用できませんので"#"にしています。（「【100－102】A」は「#100－102#A」になります。）