OKWAVEのAI「あい」が美容・健康の悩みに最適な回答をご提案!
-PR-
解決
済み

Excelブックの振り分け

  • すぐに回答を!
  • 質問No.214009
  • 閲覧数558
  • ありがとう数0
  • 気になる数0
  • 回答数3
  • コメント数0

お礼率 0% (0/18)

あるコードがファイル名となっているブックが500個(!)ほど1つのディレクトリに入っています。そのコードを基にマスタを参照して、それぞれのフォルダへ移動させたいと思います。(社員番号のファイル名でそれを基に部署フォルダに振り分けるようなイメージ)。VBAを使えばいいのでしょうが、何をどうしたものやら・・。緊急なんですが、お願いします!
通報する
  • 回答数3
  • 気になる
    質問をブックマークします。
    マイページでまとめて確認できます。

質問者が選んだベストアンサー

  • 回答No.3
レベル13

ベストアンサー率 68% (791/1163)

500個ほどのファイルを、そのファイルを基準に振り分ける例です。

マスタ(book)の
 社員番号(ファイル名)に該当するセル範囲に『社員コード』、
 部署に該当する範囲に『部署コード』の範囲名を付けます。
VBA内の2つのフォルダを設定します。
ただし、2つのフォルダが異なるドライブにあると使えません。

マスタ(book)の『社員コード』、『部署コード』が入っているシートのコードウインドウに貼り付けます。
実行する時は、元ファイルのコピー(バックアップ)を行った後、実行して下さい。


Sub Furiwake()
  Const srcFolder = "A:\社員\" '*** Bookのあるフォルダ(指定する)
  Const desFolder = "A:\部署\" '*** 振り分けるフォルダ(指定する)

  Dim fileName As String 'Excelファイル名
  Dim rg As Range '検索した社員コードのセル
  Dim schCode As String '検索する社員コード
  Dim schFolder As String '検索した社員コードに対するフォルダ

  fileName = Dir(srcFolder & "*.xls")
  While fileName <> ""
    'ファイル名からコードを取り出す
    schCode = Application.Substitute(fileName, ".xls", "")
    '取り出したコードと一致するセルを探す
    Set rg = Range("社員コード").Find(what:=schCode, LookAt:=xlWhole)
    If Not rg Is Nothing Then
      '取り出したコードと一致するセルと同じ行の部署を取り出す
      schFolder = Cells(rg.Row, Range("部署コード").Column)
      'フォルダ+ファイル名でファイル名前を変える
      Name srcFolder & fileName As desFolder & schFolder & "\" & fileName
    Else
      'コードが見つからなかった時
      MsgBox fileName & "の対象部署はありません"
    End If

    '次のExcelファイル
    fileName = Dir
  Wend
End Sub
-PR-
-PR-

その他の回答 (全2件)

  • 回答No.1
レベル9

ベストアンサー率 50% (37/73)

マスタがどんな形なのか分からないのですが、例えばExcelのワークシートのA列にコードが、B列に部署名が、1行から500行まで並んでいる様なもので、ファイル名が123.xlsのとき、コードは123だとします。 そしてC:\ABCのフォルダにファイルが500個存在し、C:\DEFのフォルダに部署名のフォルダが、例えば C:\DEF\営業部 の様な形で存在しているとします。 マスタのワークシートで、以下の ...続きを読む
マスタがどんな形なのか分からないのですが、例えばExcelのワークシートのA列にコードが、B列に部署名が、1行から500行まで並んでいる様なもので、ファイル名が123.xlsのとき、コードは123だとします。
そしてC:\ABCのフォルダにファイルが500個存在し、C:\DEFのフォルダに部署名のフォルダが、例えば C:\DEF\営業部 の様な形で存在しているとします。
マスタのワークシートで、以下のマクロを実行すればどうでしょうか。
Sub Macro1()
 Dim i As Long
 On Error Resume Next
 ChDir "C:\ABC"
 For i = 1 To 500
  Name "C:\ABC\" & Cells(i, 1) & ".xls" As "C:\DEF\" & Cells(i, 2) & "\" & Cells(i, 1) & ".xls"
 Next i
End Sub

  • 回答No.2
レベル12

ベストアンサー率 52% (206/389)

こんな感じでしょうか・・・ あとは実際の条件に合わせて文字列関数の所を変化させる、 CASEの項目を増やすなどしてください。 当方はEXCEL2000で動作確認しました。 Sub FileMoveme() Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(&q ...続きを読む
こんな感じでしょうか・・・
あとは実際の条件に合わせて文字列関数の所を変化させる、
CASEの項目を増やすなどしてください。
当方はEXCEL2000で動作確認しました。

Sub FileMoveme()
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("500個ファイルがあるフォルダのパス")
Set fc = f.Files
For Each f1 In fc
Select Case Left(f1.Name, 1)'先頭の1文字で区別する場合
Case "A"
f1.Move "振り分けるフォルダAのパス" & f1.Name
Case "B"
f1.Move "振り分けるフォルダBのパス" & f1.Name
Case "C"
f1.Move "振り分けるフォルダCのパス" & f1.Name
Case Else
End Select
Next
Set fs = Nothing
Set f = Nothing
Set fc = Nothing
End Sub
このQ&Aのテーマ
このQ&Aで解決しましたか?
関連するQ&A
-PR-
-PR-
このやり方知ってる!同じこと困ったことある。経験を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する
-PR-
-PR-
-PR-

特集


いま みんなが気になるQ&A

関連するQ&A

-PR-

ピックアップ

-PR-
ページ先頭へ