こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

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

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

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

投稿日時 - 2019-04-04 21:27:57

QNo.9603663

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

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

投稿日時 - 2019-04-07 17:49:28

ANo.1

こうでしょうか。

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

投稿日時 - 2019-04-06 21:50:40

あなたにオススメの質問