エクセルのVBA ファイルの移動

質問

同一のフォルダーに保存されたファイルを
異なるフォルダーに保存するマクロを作成したいです

例えば
ファイル名 フォルダ名
あいう様 aaa → ア あいう様
あいう様 bbb → ア あいう様
いいい様 aaa → イ いいい様
かきく様 ddd → カ かきく様
さしす様 aaa → サ さしす様
たちつ様 ccc → タ たちつ様

保存先にフォルダ名がなければ作成して保存するマクロを
作りたい場合はどのようにすればいいでしょうか？

下記のURLを使い、ファイル名を変更したあと
上記の通りにフォルダー移動がしたいです
https://www.relief.jp/docs/017844.html

回答No.2

imogasi

VBAというよりも、VBSのFSOという、エクセルVBAを補完してくれるソフトをつかえばわかりやすいのでは。VBAに含まれているとしている向きもあるが。
ーー
例えば、Googleで、「vbs fso ファイル移動」で照会し、出てくる記事の、例えば
http://www.whitire.com/vbs/tips0087.html
「ファイルを移動する」
を使って、FROMとTOに当たる、ファイルのフルパスの文字列をプログラムで作成したら済むことではないか。
その時、現フォルダ（１つ？明記のこと）を、For　Eachでループ処理してFROMに当たるファイルを、シートの該当テーブルを作っておいて、探して、見つければよい。
いっそのこと、シートにフルパスで移動前、移動後の対照表を手作業やプログラムなどで、作ってしまうのも、安心できるやり方だろう。

回答No.1

HohoPapa

こうでしょうか。

Option Explicit

'Microsoft Scripting Runtime を参照設定

Sub Test1()

　Const GetDir = "D:\Test\FDir" '複写元フォルダー
　Const PutDir = "D:\Test\TDir" '複写先フォルダー
　Const KeyTex = "様"

　Dim FSO As New Scripting.FileSystemObject
　Dim fl As Folder
　Dim f As File
　Dim PutFName As String
　Dim wsDir As String
　Dim KeyPos As Long

　Set fl = FSO.GetFolder(GetDir)

　For Each f In fl.Files ' フォルダ内のファイルを取得
　　wsDir = StrConv(Left(f.Name, 1), vbKatakana)
　　If FolderExists(PutDir & "\" & wsDir) = False Then
　　　MkDir PutDir & "\" & wsDir
　　End If
　　KeyPos = InStr(f.Name, KeyTex)
　　PutFName = Left(f.Name, KeyPos)
　　PutFName = PutDir & "\" & wsDir & "\" & PutFName & "." & getExtxt(f.Name)
　　FileCopy f.Path, PutFName
　Next
　Set FSO = Nothing
End Sub

'拡張子を取得する関数
Function getExtxt(FPath) As String
　Dim FSO As New Scripting.FileSystemObject
　Dim filePath As String
　Dim ExtentionName As String
　getExtxt = FSO.GetExtensionName(FPath)
　Set FSO = Nothing
End Function

'フォルダーの有無判定
Function FolderExists(folder_path As String) As Boolean
　Dim FSO As New Scripting.FileSystemObject
　If FSO.FolderExists(folder_path) Then
　　FolderExists = True
　Else
　　FolderExists = False
　End If
　Set FSO = Nothing
End Function