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

このQ&Aに関連する最新のQ&A

A 回答 (3件)

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
    • good
    • 0

こんな感じでしょうか・・・


あとは実際の条件に合わせて文字列関数の所を変化させる、
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
    • good
    • 0

マスタがどんな形なのか分からないのですが、例えば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
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qファイル名と同名のフォルダを自動作成して移動させる方法はありますか?

windows XPユーザです。
フォルダ内にある複数のファイル(例えば、word)を1つのファイルごとに分類したいため、そのファイル名と同名のフォルダを元のフォルダ内に新たに作成し、そこに保存したいと思っていますが、ファイルが多数あるため、全てのフォルダについて新規フォルダを自分で作成するのが大変で困っています。何か一括でファイル名と同名のフォルダを作成する方法はないでしょうか?

Aベストアンサー

Excelで代用する方法です。

1.新規でExcelを開き、Wordファイルが保存されているフォルダのパス
 をセルA1に入力します。
  例)C:\MyData\Docs\Word
2.[Alt]+[F11] で VB Editor を開き、標準モジュールに次のとおり
 記述(コピペ)します。
 '
 Sub CrtFileNameDir()
  Dim FPath, TargetFile, DName
  FPath = Range("A1").Value
  If FPath = "" Then Exit Sub
  TargetFile = Dir$(FPath & "\*.doc")
  Do While TargetFile <> ""
   DName = Left(TargetFile, InStrRev(TargetFile, ".") - 1)
   On Error GoTo Er
   MkDir FPath & "\" & DName
   FileCopy FPath & "\" & TargetFile, FPath & "\" & DName _
      & "\" & TargetFile
   Kill FPath & "\" & TargetFile
   TargetFile = Dir$
  Loop
 Er: On Error GoTo 0
 End Sub
 '
3.VB Editor を閉じ、[ツール]-[マクロ]-[マクロ] から、上記マクロを
 実行します。

Excelで代用する方法です。

1.新規でExcelを開き、Wordファイルが保存されているフォルダのパス
 をセルA1に入力します。
  例)C:\MyData\Docs\Word
2.[Alt]+[F11] で VB Editor を開き、標準モジュールに次のとおり
 記述(コピペ)します。
 '
 Sub CrtFileNameDir()
  Dim FPath, TargetFile, DName
  FPath = Range("A1").Value
  If FPath = "" Then Exit Sub
  TargetFile = Dir$(FPath & "\*.doc")
  Do While TargetFile <> ""
   DName = Left(TargetFile, InStrRev(Ta...続きを読む

Qフォルダ名の記述方法について御教示ください。VBA

いつも御指導ありがとうございます。

皆様に御指導いただきながら、得意先別元帳の項目(前月残・当月入金・売上・残高等)の金額を取得して売掛金管理表を作成しています。

得意先別元帳のフォルダ名を年度(yyyyの部分)としている為に、変更しないと毎年使用できません。

売掛金管理表のセル(L5)に、年度が記載されていますので、それを利用してみましたが上手く出来ません。

変更しないで処理出来るようにするための記述を御教示御願申し上げます。

●フォルダ構成
C:\Documents and Settings\aaa\My Documents\販売\yyyy年11月決算\売掛金元帳 ー 各得意先ファイル
C:\Documents and Settings\aaa\My Documents\販売\yyyy年11月決算\管理表 ー 売掛金管理表と買掛金管理表ファイル

Sub GetDatainFolder6() '管理表の作成
Dim i As Long
Dim Fname As String
Dim ans As Variant

DoEvents
Const myFolder As String = "C:\Documents and Settings\aaa\My Documents\販売\yyyy年11月決算\売掛金元帳\"
Fname = Dir(myFolder & "*.xls")
Do Until Len(Fname) = 0
FormPickUP Range("C6").Offset(i), myFolder & Fname, "6月"
Range("C6").Offset(i).Resize(, 7).Value = _
Range("C6").Offset(i).Resize(, 7).Value
Range("D6").Offset(i).Value = Mid(Fname, 1, InStrRev(Fname, ".") - 1) '拡張子は取る
i = i + 1
Fname = Dir()
Loop
End Sub

Function FormPickUP(rng As Range, ByVal myBk As String, ByVal mySh As String)
省略
End Function
宜しく御願いいたします。

いつも御指導ありがとうございます。

皆様に御指導いただきながら、得意先別元帳の項目(前月残・当月入金・売上・残高等)の金額を取得して売掛金管理表を作成しています。

得意先別元帳のフォルダ名を年度(yyyyの部分)としている為に、変更しないと毎年使用できません。

売掛金管理表のセル(L5)に、年度が記載されていますので、それを利用してみましたが上手く出来ません。

変更しないで処理出来るようにするための記述を御教示御願申し上げます。

●フォルダ構成
C:\Documents and Setting...続きを読む

Aベストアンサー

こんばんは。

返事が遅くなり、すみません。お礼側だけを、メールで受け取って呼んでいました。

>どのパソコンでも使用できるような記述方法があるのでしょうか。

それは、こんな方法です。

Dim myFolder As String
Dim UserName As String
UserName = Environ("USERNAME")
myFolder = "C:\Documents and Settings\" & UserName & "\My Documents\¥販売管理\2009年11月決算\売掛金元帳\"

>Environ("USERNAME")
これは、単に環境変数を読んでいるだけです。
コマンド・プロンプトで、>Set とすれば、出てきます。

QエクセルVBA フォルダ内のどんなシート名であっても読み込みたい

フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。
よろしくお願いします。

Sub test_1()
Dim wb As Workbook
Dim ws As Worksheet
Dim ms As Worksheet
Dim nb As Workbook
Dim r As Long

Set ms = ThisWorkbook.Worksheets("メニュー")
Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value)
Set ws = wb.Worksheets("情報")
Set nb = Workbooks.Add
With ws
.Range("Q1").AutoFilter _
Field:=17, _
Criteria1:=">=" & ms.Range("D5").Text, _
Operator:=xlAnd, _
Criteria2:="<=" & ms.Range("F5").Text
With .AutoFilter.Range
r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

If r = 1 Then
MsgBox "抽出対象データ無し。"
wb.Close False
nb.Close False
Set wb = Nothing: Set ws = Nothing
Set ms = Nothing: Set nb = Nothing
Exit Sub
End If
.Copy
End With
End With
With nb.Worksheets(1)
.Paste
With .Range("A1:AG1")
.Interior.ColorIndex = 6
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End sub

フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。
よろしくお願いします。

Sub test_1()
Dim wb As Workbook
Dim ws As Worksheet
Dim ms A...続きを読む

Aベストアンサー

Set ws = wb.Worksheets(1)
です。

QVBAなどでファイル名の入力で、特定のフォルダから画像を挿入する。

VBAなどでファイル名の入力で、特定のフォルダから画像を挿入する。

お世話になります。
当方、エクセル少々、アクセス初心者、VBAはこれから勉強です。
環境 windows xp pro sp3

アクセスやエクセルで作った伝票に、製品のイラストを載せたいと考え

特定のフォルダにある画像ファイルと同じファイル名を入力すると、
その画像をシートやレポートのきまった場所に
ちょうどいい大きさに自動的に挿入してくれることを
希望しています

とりあえず、できるかできないか、ということと、
検索も、どの言葉で検索していいのかわからなかったので、
簡単に何を使ってやるのかなど、教えていただけたら幸いです。

また、他のソフトなどでも、いい方法があったらよろしくお願いします。

Aベストアンサー

Access なら、以下が参考になると思います


写真付レポートの作成:SampleFile077
http://www.accessclub.jp/samplefile/samplefile_77.htm

Qフォルダ内のファイルを読み取り専用にするソフト

過去に作成したファイルを誤って上書き保存しないように、
全て読み取り専用に設定したいのですが、
ファイルが数百もあるので一つ一つ設定するのは耐えられません。

なにかフォルダ内のファイルを一括して読み取り専用の
設定に出来るソフトはないでしょうか。

なるべくならフリーウェアでない有名なソフト会社が
作った商品が知りたいです。

Aベストアンサー

読み取り専用にするファイルやフォルダなどを
マウスで範囲指定して右クリックを行いプロパティを開き属性のところで
読み取り専用にチェックを入れてOKをクリックすればできます。


人気Q&Aランキング

おすすめ情報