人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルマクロVBA ファイル名を区別して特定フォルダに移動したい


詳しくは画像をご確認ください。


あるエクセルファイルの、
BD9セルに、P180303550.jpg(これは仮です)

というようなP+数字+.jpgの組み合わせで、桁数は常にかわらないものがはいっています。


マクロを実行すると、特定の画像フォルダ内から、その番号【1】より上のもの、【2】以下のもの
とわけて特定のフォルダに移動したいのです。(フォルダ内の総画像数は一定ではありません。桁数の合うものだけの移動で十分です)


移動元の画像ファイルは、
C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\180303

というように、エクセルファイルのBD9セルのPと、550までの間の数字、180303をもとにしたフォルダに入っています。


移動先ファイルは、

【1】C:\Users\naranara19\Desktop\auc
【2】C:\Users\naranara19\Desktop\auc2

に移したいです。jpgファイルのみ対象です。


なお、FileSystemObject を参照できるようにしています。


お手数ですがよろしくお願いいたします。

1520042146
●拡大する

●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● 7knights
●300ポイント

BD9セルにP180303550.jpgというようなP+数字+.jpgの組み合わせで桁数は常にかわらないものがはいっているエクセルファイルのシートがアクティベイトになっているとすると,こんな感じでいけるのではないかと思います。(debugしてないので自信ないけど,FileSystemObjectを使うので自己責任でお願いします。)
Sub ファイル名を区別して特定フォルダに移動したい()
Set FS = CreateObject("Scripting.FileSystemObject")
BASE_FILE_NAME = ThisWorkbook.ActiveSheet.Range("BD9")
Select Case IsEmpty(BASE_FILE_NAME)
Case True
Case False
BASE_NUMBER = Val(Mid(BASE_FILE_NAME, 2, 6))
DIR_FROM = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\" & Format(BASE_NUMBER) & "\"
Select Case FS.FolderExists(DIR_FROM)
Case True
DIR_AUC1 = "C:\Users\naranara19\Desktop\auc\"
Select Case FS.FolderExists(DIR_AUC1)
Case True
Case False
MkDir DIR_AUC1
End Select
DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\"
Select Case FS.FolderExists(DIR_AUC2)
Case True
MkDir DIR_AUC2
Case False
End Select
For Each F In FS.GetFolder(DIR_FROM).Files
Select Case Mid(F.Name, Len(F.Name) - 3, 4)
Case ".jpg"
Select Case Mid(F.Name, 1, 1)
Case "P"
Select Case Val(Mid(F.Name, 2, 6))
Case Is > BASE_NUMBER
DIR_AUC = DIR_AUC1
Case Else
DIR_AUC = DIR_AUC2
End Select
F.Move DIR_AUC
Case Else
End Select
Case Else
End Select
Next
Case False
End Select
End Select
End Sub


naranara19さんのコメント
ありがとうございます。早速やってみたのですが、エラーはでないのですが、ファイルが移動されないのです。途中試しているときにコピペミスとかしたのですが、そういうことをした場合は初めからやり直す必要はありますか?

naranara19さんのコメント
申し訳ございません。いま気づいたのですが、 移動元の画像ファイルは、 C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\180303 の部分の最後が逆で、 移動元の画像ファイルは、 C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\180303\jiriki でした。大変失礼しました。 これは下記の下記のように直せばいいですか? DIR_FROM = "C:\Users\naraoka\Desktop\PC移動受け\写真(現在)\" & Format(BASE_NUMBER) & "\" & "jiriki\" こうしたとしたら、「パス名が無効です。」として、 MkDir DIR_AUC2のところでエラーが出てしまいます。

7knightsさんのコメント
すみません。私も今気づいたのですが,そのMkdir DIR_AUC2の記述行が間違ってました。 DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\" Select Case FS.FolderExists(DIR_AUC2) Case True MkDir DIR_AUC2 Case False End Select のところを DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\" Select Case FS.FolderExists(DIR_AUC2) Case True Case False MkDir DIR_AUC2 End Select に修正すると良いかと思います。

7knightsさんのコメント
ついでに,再実行したようなときに,既に移動先のフォルダに同じ名前のファイルがあるときを想定して, F.Move DIR_AUC を Select Case FS.FileExists(DIR_AUC & F.Name) Case True Case False F.Move DIR_AUC End Select のようにしておくと良いかもしれません。

naranara19さんのコメント
ありがとうございます!! 無事移動できたのですが、auc2の方にすべてが移動されてしまうのですが、これはどうしてでしょうか?

7knightsさんのコメント
すみません。移動元フォルダ内のファイル名とBD9セルのファイル名の関係を読み違えていました。修正したものを張り付け直します。 Sub ファイル名を区別して特定フォルダに移動したい() Set FS = CreateObject("Scripting.FileSystemObject") BASE_FILE_NAME = ThisWorkbook.ActiveSheet.Range("BD9") Select Case IsEmpty(BASE_FILE_NAME) Case True Case False DIR_FROM = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\" & Mid(BASE_FILE_NAME, 2, 6) & "\jiriki\" Select Case FS.FolderExists(DIR_FROM) Case True DIR_AUC1 = "C:\Users\naranara19\Desktop\auc\" Select Case FS.FolderExists(DIR_AUC1) Case True Case False MkDir DIR_AUC1 End Select DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\" Select Case FS.FolderExists(DIR_AUC2) Case True Case False MkDir DIR_AUC2 End Select BASE_NUMBER = Val(Mid(BASE_FILE_NAME, 2, 9)) For Each F In FS.GetFolder(DIR_FROM).Files Select Case Mid(F.Name, Len(F.Name) - 3, 4) Case ".jpg" Select Case Mid(F.Name, 1, 1) Case "P" Select Case Val(Mid(F.Name, 2, 6)) Case Is > BASE_NUMBER DIR_AUC = DIR_AUC1 Case Else DIR_AUC = DIR_AUC2 End Select Select Case FS.FileExists(DIR_AUC & F.Name) Case True Case False F.Move DIR_AUC End Select Case Else End Select Case Else End Select Next Case False End Select End Select End Sub

naranara19さんのコメント
ありがとうございます。 やってみたのですが、 ありがとうございます! やってみたのですが、今度は反応しないようです。 たとえば、180303のフォルダですと、そのパスは C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\180303\jiriki となるのですが、私の方で指示ミスをしていましたでしょうか。

7knightsさんのコメント
ごめんなさい。もう一か所修正漏れでした。 Select Case Mid(F.Name, 1, 1) Case "P" Select Case Val(Mid(F.Name, 2, 6)) のところを Select Case Mid(F.Name, 1, 1) Case "P" Select Case Val(Mid(F.Name, 2, 9)) 'ここです に修正をお願いします。

naranara19さんのコメント
申し訳ございませんでした。下記の方にもお伝えしましたが、 これはBD9セルに書式設定で "P"G/標準".jpg" のような設定にしているのが原因でエラーが出ていたようです。変わりますでしょうか。 いろいろとお手数をおかけして申し訳ありませんでした。

7knightsさんのコメント
それでは,次のコードをお試しください。 Sub ファイル名を区別して特定フォルダに移動したい() Set FS = CreateObject("Scripting.FileSystemObject") Select Case IsEmpty(ThisWorkbook.ActiveSheet.Range("BD9")) Case True Case False BASE_NUMBER = ThisWorkbook.ActiveSheet.Range("BD9") DIR_FROM = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\P" & Format(Int(BASE_NUMBER / 1000)) & ".jpg\jiriki\" Select Case FS.FolderExists(DIR_FROM) Case True DIR_AUC1 = "C:\Users\naranara19\Desktop\auc\" Select Case FS.FolderExists(DIR_AUC1) Case True Case False MkDir DIR_AUC1 End Select DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\" Select Case FS.FolderExists(DIR_AUC2) Case True Case False MkDir DIR_AUC2 End Select For Each F In FS.GetFolder(DIR_FROM).Files Select Case Mid(F.Name, Len(F.Name) - 3, 4) Case ".jpg" Select Case Mid(F.Name, 1, 1) Case "P" Select Case Val(Mid(F.Name, 2, 9)) Case Is > BASE_NUMBER DIR_AUC = DIR_AUC1 Case Else DIR_AUC = DIR_AUC2 End Select Select Case FS.FileExists(DIR_AUC & F.Name) Case True Case False F.Move DIR_AUC End Select Case Else End Select Case Else End Select Next Case False End Select End Select End Sub

naranara19さんのコメント
ありがとうございます。エラーは出ないのですが、なぜか移動されませんでした。 長くなりましたので、これで終わりといたしますね。 長々とご親切にしていただき、本当にありがとうございました。

2 ● Z1000S
●500ポイント ベストアンサー

2018/03/05 07:54コード差し替えを行いました。

こんな感じでできませんでしょうか?
フォルダーの有無や境界値となるBD9のセルの値などデータの整合性のチェック処理、およびエラー発生時の処理は入れてありません。必要に応じて追加していただければと思います。


Public Sub movePictures改()

'元データフォルダ
Const SOURCE_FOLDER_MAIN As String = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\"
Const SOURCE_FOLDER_SUB As String = "\jiriki"

'移動対象拡張子
Const TARGET_EXTENTION As String = ".jpg"

'移動先フォルダ
Const DEST_FOLDER1 As String = "C:\Users\naranara19\Desktop\auc"
Const DEST_FOLDER2 As String = "C:\Users\naranara19\Desktop\auc2"

'ファイル名桁数
Const FILE_NAME_LENGTH As Long = 10

'親フォルダ名桁数
Const PARENT_FOLDER_NAME_LENGTH As Long = 6
'親フォルダ名開始位置
Const PARENT_FOLDER_NAME_BEGIN_POS As Long = 2

'境界となるファイル名の記載されているシート
Const TARGET_SHEET_NAME As String = "Sheet1"

'境界となるファイル名の記載されているセル
Const TARGET_CELL_ADDRESS As String = "BD9"

Dim fso As New FileSystemObject
Dim f As FILE
Dim sFileName As String
Dim sBoundary As String
Dim sParentFolderName As String
Dim sSourceFolder As String
Dim sSourcePath As String
Dim sDestPath As String

'境界となるファイル名の取得
sBoundary = ThisWorkbook.Worksheets(TARGET_SHEET_NAME).Range(TARGET_CELL_ADDRESS).Value
sBoundary = Left$(sBoundary, FILE_NAME_LENGTH)

'親フォルダ名(可変部)の取得
sParentFolderName = Mid$(sBoundary, PARENT_FOLDER_NAME_BEGIN_POS, PARENT_FOLDER_NAME_LENGTH)

'親フォルダの設定
sSourceFolder = SOURCE_FOLDER_MAIN & sParentFolderName & SOURCE_FOLDER_SUB

For Each f In fso.GetFolder(sSourceFolder).Files
'対象拡張子かの判定
If LCase(Right$(f.Name, Len(TARGET_EXTENTION))) = TARGET_EXTENTION Then
sFileName = Left$(f.Name, FILE_NAME_LENGTH)

If sFileName >= sBoundary Then
'境界値以上
sDestPath = DEST_FOLDER2
Else
'境界値未満
sDestPath = DEST_FOLDER1
End If

sSourcePath = sSourceFolder & "\" & f.Name
sDestPath = sDestPath & "\" & f.Name

'移動
Call fso.MoveFile(sSourcePath, sDestPath)
End If
Next

Set fso = Nothing

End Sub


naranara19さんのコメント
ありがとうございます!先の回答の方にもあるのですが、条件を間違いてしまっておりまして、 移動元の画像ファイルは、 C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\180303 の部分の最後が逆で、 移動元の画像ファイルは、 C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\180303\jiriki でした。大変失礼しました。 それと、いただいたファイルはしっかりと動いたのですが、 '元データフォルダ Const SOURCE_FOLDER As String = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\180303" の180303はそれ特定というわけではなく、 BD9のセルの内容を読み取ってフォルダ名を特定する形です。この部分をお願いしてもよろしいでしょうか。

Z1000Sさんのコメント
コメント欄だけでは修正内容を伝えきれないと判断し、投稿したコードを修正しました。 意図した動作となっていますでしょうか? 拡張子jpgのファイルのみ処理対象としていますが、 If LCase(Right$(f.Name, Len(TARGET_EXTENTION))) = TARGET_EXTENTION Then を If LCase(f.Name) Like "p#########.jpg" Then とすれば、もう少しシビアにチェックできます。

naranara19さんのコメント
ありがとうございます! やってみたのですが、 For Each f In fso.GetFolder(sSourceFolder).Files のところで「パスが見つかりません」 とエラーがでてしまいます。 たとえば、180303のフォルダですと、そのパスは C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\180303\jiriki となるのですが、私の方で指示ミスをしていましたでしょうか。

Z1000Sさんのコメント
「パスが見つかりません」のエラーは、FileSystemObjectに渡したsSourceFolderの値が正しくないということです。 こちらで確認した限りでは問題はなさそうです。 sSourceFolderに実際に格納されている値は、 1.ブレークポイントを設定する 2.Debug.Print sSourceFolder をsSourceFolderを生成した後に追記する 3.メッセージボックスでsSourceFolderを表示させる 等、幾つかの確認方法があるので、確かめてみていただければと思います。 実際のフォルダのパスは、間違いないでしょうか? 提示されたパスのアルファベット、カッコ、数字は、全て半角の文字となっていますが、実際のパスでそれらの中に全角の文字があったりといったことはないでしょうか?あるいは、どこか途中にスペースが有ったりとか? コマンドプロンプトで、 dir C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\180303\jiriki として、きちんとファイル名が表示されますか? もし、「指定されたパスが見つかりません。」と表示されるようであれば、パスの指定が間違っています。

naranara19さんのコメント
ありがとうございます。 コマンドプロンプトによるものでは、パスは問題なく、 教えていただいたMsgboxをエラーのでた直前に設定しました。 すると、 C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\803055\jiriki となりました。 これはBD9セルに書式設定で "P"G/標準".jpg" のような設定にしているのが原因でしょうか。 よく考えましたら動いたときなどは、他のセルからBD9セルに直接貼り付けてこのセルの書式設定を リセットしていた気がいたします。 このセルの書式設定のままだとしましたら、どのようなコードに変わりますでしょうか。 いろいろとお手数をおかけして申し訳ありませんが、 何卒よろしくお願い申し上げます。

Z1000Sさんのコメント
>これはBD9セルに書式設定で > >"P"G/標準".jpg" > >のような設定にしているのが原因でしょうか。 はい、その通りです。 書式設定で、"P"G/標準".jpg"と指定した場合、 セル上で、「P180303550.jpg」と見えている状態では、実際にセルに入っている値は、「180303550」の場合と、本当に「P180303550.jpg」が入っている場合のどちらもありえます。外観上区別がつきません。 「180303550」が入っていることを前提とするのであれば、以下のような処理でいかがでしょうか? <pre><code> Public Sub movePictures改2() '元データフォルダ Const SOURCE_FOLDER_MAIN As String = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\" Const SOURCE_FOLDER_SUB As String = "\jiriki" '移動先フォルダ Const DEST_FOLDER1 As String = "C:\Users\naranara19\Desktop\auc" Const DEST_FOLDER2 As String = "C:\Users\naranara19\Desktop\auc2" 'ファイル名パターン(UCaseしたものとの比較に使うので、アルファベットは大文字必須) Const FILE_NAME_PATTERN As String = "P#########.JPG" 'ファイル名プレフィックス長 Const FILE_NAME_PREFIX_LENGTH As Long = 1 'ファイル名長(拡張子を含まない) Const FILE_NAMNE_LENGTH_WITHOUT_EXTENSION As Long = 10 '親フォルダ名桁数 Const PARENT_FOLDER_NAME_LENGTH As Long = 6 '境界となるファイル名の記載されているシート Const TARGET_SHEET_NAME As String = "Sheet1" '境界となるファイル名の記載されているセル Const TARGET_CELL_ADDRESS As String = "BD9" Dim fso As New FileSystemObject Dim f As FILE Dim lFileNameLength As Long Dim sFileName As String Dim sBoundary As String Dim sParentFolderName As String Dim sSourceFolder As String Dim sSourcePath As String Dim sDestPath As String '境界となるファイル名の取得(プレフィックス無し、拡張子無し) sBoundary = ThisWorkbook.Worksheets(TARGET_SHEET_NAME).Range(TARGET_CELL_ADDRESS).Value '親フォルダ名の取得 sParentFolderName = Left$(sBoundary, PARENT_FOLDER_NAME_LENGTH) '親フォルダの設定 sSourceFolder = SOURCE_FOLDER_MAIN & sParentFolderName & SOURCE_FOLDER_SUB For Each f In fso.GetFolder(sSourceFolder).Files 'ファイル名から処理対象ファイルか判定 If UCase(f.Name) Like FILE_NAME_PATTERN Then sFileName = Mid$(f.Name, FILE_NAME_PREFIX_LENGTH + 1, FILE_NAMNE_LENGTH_WITHOUT_EXTENSION - FILE_NAME_PREFIX_LENGTH) If sFileName >= sBoundary Then '境界値以上 sDestPath = DEST_FOLDER2 Else '境界値未満 sDestPath = DEST_FOLDER1 End If sSourcePath = sSourceFolder & "\" & f.Name sDestPath = sDestPath & "\" & f.Name '移動 Call fso.MoveFile(sSourcePath, sDestPath) End If Next Set fso = Nothing End Sub</code></pre> 私的な意見を言わせてもらえば、BD9の書式設定はしない方が、後々トラブルに巻き込まれる確率が減るように思います。 見た目と中身が違うのは、混乱の原因になりますので・・・ もしどうしても9桁の数字のみの入力にしたいのであれば、BD9の両脇のセルが空いているようであれば、BC9に「P」、BE9に「.jpg」を予め入力しておくといった方法も考えられます。

naranara19さんのコメント
いろいろとお手数をおかけいたしました! 完璧に動作いたしました。 様々なアドバイスも大変役に立ちまして感謝しております。 これで終了したいと思います。 もしよろしければ、http://q.hatena.ne.jp/1519768163 にもご回答いただけたら大変ありがたいです。 ややこしく見えますが、今回のようなことはなく、たんなる行列の入れ替えです。 よろしければご協力くださいませ。 本当にありがとうございました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ