[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロでサブフォルダ内の特定ファイルを抜き出して保存』（まくりん）
あるフォルダに、作業用.xlsmがあり、 同一フォルダ内に、日付の入ったフォルダが100ほどあります。
その中に、ノートA* ノートB*というエクセルが入っている場合と 入っていない場合があります。
入っている場合は、それをコピーして 作業用.xlsmと同一フォルダにある「保存フォルダ」に フォルダ名の名前を付けて保存したいです。 (ノートA_フォルダ名.xlsx）という感じです。
マクロで実現したいのですが、なかなかうまくいきません。
Sub Sample()
Dim stPath As String
Dim yyFold As Object
Dim csFold As Object
Dim bkName As String
Dim bkPath As String
Dim fso As Object
Dim yrBook As Workbook
Dim myBook As Workbook
Dim cnt As Long
Dim z As Long
Application.ScreenUpdating = False
stPath = ThisWorkbook.Path
bkName = "ノートA*.xls"
Set fso = CreateObject("Scripting.FIleSystemObject")
For Each yyFold In fso.getfolder(stPath).subfolders
If IsNumeric(yyFold.Name) Then
For Each csFold In yyFold.subfolders
bkPath = csFold.Path & "\" & bkName
If fso.FileExists(bkPath) Then
Set yrBook = Workbooks.Open(bkPath)
cnt = cnt + 1
yrBook.SaveAs Filename:=ThisWorkbook.Path & "\保存フォルダ\" & csFold.Name & ".xls"
yrBook.Close False
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub
どなたかご教授ください。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
（名無し） 2018/09/27(木) 16:08
横から失礼します。
参考HPです。
Dir関数が便利です。
http://officetanaka.net/excel/vba/function/Dir.htm
（カリーニン） 2018/09/27(木) 16:11
ワイルドカードをはずしてもうまくいきません。 全ファイルでも問題ないのですが、、、
Sub Sample()
Dim stPath As String
Dim yyFold As Object
Dim csFold As Object
Dim bkName As String
Dim bkPath As String
Dim fso As Object
Dim yrBook As Workbook
Dim myBook As Workbook
Dim cnt As Long
Dim z As Long
Application.ScreenUpdating = False
stPath = ThisWorkbook.Path
bkName = "*.xlsx"
Set fso = CreateObject("Scripting.FIleSystemObject")
For Each yyFold In fso.getfolder(stPath).subfolders
If IsNumeric(yyFold.Name) Then
For Each csFold In yyFold.subfolders
bkPath = csFold.Path & "\" & bkName
If fso.FileExists(bkPath) Then
Set yrBook = Workbooks.Open(bkPath)
cnt = cnt + 1
yrBook.SaveAs Filename:=ThisWorkbook.Path & "\保存フォルダ\" & csFold.Name & ".xls"
yrBook.Close False
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub （まくりん） 2018/09/27(木) 16:18
＞カリーニンさま コピーしたいファイルはサブフォルダ内にあるのです。m(__)m （まくりん） 2018/09/27(木) 16:20
そして、探すファイルは.xlsx形式に変わりましたが、保存するのはxls形式ですか？ このままだと中身はxlsxなのに拡張子はxlsになって、開くとエラーになりませんか？
ところで、ブックを開いて別名保存するのではなく、ファイルコピーにした方が簡単だったりしませんか？
（???） 2018/09/27(木) 16:26
保存はxlsx形式です。 コピーで大丈夫です。 全ファイル、サブフォルダ名でコピーしたいです。 （まくりん） 2018/09/27(木) 16:36
すべてのファイルをコピーし、サブフォルダ名で保存する に変更しましたが、エラーになります。 どなたかご教示いただけると嬉しいです
Sub FileCopy()
Dim fsosubfolder As Object
Dim copyToFolder As String
Dim fso As Object
Dim sourceFile
Set fso = CreateObject("Scripting.FIleSystemObject")
stPath = ThisWorkbook.Path
For Each fsosubfolder In fso.getfolder(stPath).subfolders
Set sourceFile = fsosubfolder.Files
For Each sourceFile In fsosubfolder copyToFolder = ThisWorkbook.Path & "\保存フォルダ\" fso.CopyFile sourceFile, copyToFolder Next
Next
Set fso = Nothing
End Sub
（まくりん） 2018/09/27(木) 17:04
そして、Set sourceFile = fsosubfolder.Files しているのに、直後に For Each sourceFile In fsosubfolder って何ですか？ sourceFileはフォルダ内のファイル群を代入したのなら、次のFor Eachは別のオブジェクトがsourceFileのファイル数分ループするのでしょう？ 乱暴すぎます。よく考えてください。
そして、ファイル名にサブフォルダ名を加えてリネームする部分が無くなったのですが、それではただのコピーですよ？
（???） 2018/09/27(木) 17:39
いろいろと急ぎすぎてぐちゃぐちゃでしたね。 ご指摘ありがとうございます。 考え直して出直します。 すみませんでした。 （まくりん） 2018/09/27(木) 21:16
むかーしSHFileOperationを使ったファイルコピーの勉強用に作ったモジュールがあったので、 ひょっとしたら流用できるかな? と思うのでちょっと貼っておきますね。 途中でホッタラカシにしちゃったし、当時とはPC環境も違うんで、アヤシイですが^^; (んなモン貼るなって?)
SHFileOperation実験用モジュールは↓こんな感じ(標準モジュール)
Option Explicit
Option Private Module
#If VBA7 Then
Private Type SHFILEOPSTRUCT
hWnd As LongPtr ''ウィンドウハンドル
wFunc As Long ''実行する操作
pFrom As String ''対象ファイル名
pTo As String ''目的ファイル名
fFlags As Integer ''フラグ
fAnyOperationsAborted As Long ''結果
hNameMappings As LongPtr ''ファイル名マッピングオブジェクト
lpszProgressTitle As String ''ダイアログのタイトル
End Type
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" (lpFileOp As SHFILEOPSTRUCT) As Long
#Else
Private Type SHFILEOPSTRUCT
hWnd As Long ''ウィンドウハンドル
wFunc As Long ''実行する操作
pFrom As String ''対象ファイル名
pTo As String ''目的ファイル名
fFlags As Integer ''フラグ
fAnyOperationsAborted As Long ''結果
hNameMappings As Long ''ファイル名マッピングオブジェクト
lpszProgressTitle As String ''ダイアログのタイトル
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" (lpFileOp As SHFILEOPSTRUCT) As Long
#End If
Private Const FO_MOVE = &H1 '移動
Private Const FO_COPY = &H2 'コピー
Private Const FO_DELETE = &H3& '削除
Private Const FO_RENAME = &H4 '名前を変更
Private Const FOF_MULTIDESTFILES = &H1& '複数ファイル指定
Private Const FOF_SILENT = &H4& 'プログレスバー非表示
Private Const FOF_RENAMEONCOLLISION = &H8& '操作結果ファイルの重複名回避
Private Const FOF_NOCONFIRMATION = &H10& '上書き・削除の確認ダイアログを表示しない
Private Const FOF_ALLOWUNDO = &H40& 'ごみ箱へ
Private Const FOF_FILESONLY = &H80& 'ワイルドカード指定のみの操作
Private Const FOF_SIMPLEPROGRESS = &H100& 'プログレスバー中にファイル名非表示
Private Const FOF_NOCONFIRMMKDIR = &H200& 'コピー先フォルダが存在しない場合、フォルダ作成確認無し
Private Const FOF_NOERRORUI = &H400& 'エラーのダイアログを表示しない
Private Const FOF_NORECURSION = &H800& 'サブフォルダ再帰的処理無し
Private ListAry() As Variant, Cnt As Long, FSO As Object
Function FileCopyByFO(Source As Variant, ByVal Destination As Variant) As Long
Rem ---------------------------------------------------------------------------------------------------------
Rem Source フルパスで指定(ファイル名にはワイルドカード使用可)
Rem フルパスを格納した配列で複数指定しても可
Rem Destination フルパスで指定した方が無難(ファイル名だけだとカレントディレクトリに行くっぽいけど)
Rem フルパスを格納した配列で指定しても可
Rem Sourceが配列でDestinationが１箇所指定だったら、Destinationにファイルが集まる
Rem 両方配列だったら各配列の対応する要素間でコピーする
Rem ---------------------------------------------------------------------------------------------------------
Dim ShOPs As SHFILEOPSTRUCT, Flg As Long
Dim SourceStr As String, DestStr As String
Flg = FOF_NOCONFIRMATION + FOF_NOCONFIRMMKDIR '重複名回避+フォルダ作成確認無し
If IsArray(Source) Then 'Sourceが配列だったら\0でjoin
SourceStr = Join(Source, vbNullChar)
' SourceStr = SourceStr & String(2, vbNullChar) '最後に\0\0を付け加えろという話だったがエラーになった
Else
SourceStr = CStr(Source)
End If
If IsArray(Destination) Then 'Destinationが配列だったら\0でjoinして、
DestStr = Join(Destination, vbNullChar)
Flg = Flg + FOF_MULTIDESTFILES '複数ファイル指定フラグを加える
Else
DestStr = CStr(Destination)
End If
With ShOPs
.hWnd = 0
.wFunc = FO_COPY
.pFrom = SourceStr
.pTo = DestStr
.fFlags = Flg
End With
FileCopyByFO = SHFileOperation(ShOPs)
End Function
Function ListFilesBy(ResList() As Variant, ByVal TargetPath As String, ByVal Mask As String, Optional ModifiedLimit As Date) As Long
Rem ---------------------------------------------------------------------------------------------------------
Rem TargetPath配下(サブフォルダ含む)からMaskに一致するファイル名のフルパスをResListに入れて返す
Rem 戻り値は一致したファイル数
Rem ModifiedLimitはファイル更新日の下限を指定するオプション
Rem ---------------------------------------------------------------------------------------------------------
Cnt = 0
Erase ListAry
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(TargetPath) Then
Call FoldersListup(TargetPath, Mask, ModifiedLimit)
End If
ResList = ListAry
ListFilesBy = Cnt
Set FSO = Nothing
End Function
Rem 以下Private処理==========================================================================================
Private Sub FoldersListup(Path As String, Mask As String, ModifiedLimit As Date)
Rem サブフォルダ内のファイル探索を再帰的に実行
Dim aFolder As Object
For Each aFolder In FSO.GetFolder(Path).SubFolders
Call FoldersListup(aFolder.Path, Mask, ModifiedLimit)
Next
Call FilesListup(Path, Mask, ModifiedLimit)
End Sub
Private Sub FilesListup(Path As String, Mask As String, ModifiedLimit As Date)
Rem Dir関数使わない理由は特にないんだが・・・気分で
Dim aFile As Object
For Each aFile In FSO.GetFolder(Path).Files
If StrConv(aFile.Name, vbLowerCase) Like StrConv(Mask, vbLowerCase) Then
If aFile.DateLastModified >= ModifiedLimit Then
Cnt = Cnt + 1
ReDim Preserve ListAry(1 To Cnt)
ListAry(Cnt) = aFile.Path
End If
End If
Next
End Sub
で、 別の標準モジュールでこんな風に書いてみるという・・・ (とりあえず「ノートA*」の場合だけですけど)
Sub test()
Dim r() As Variant, c As Long, w() As Variant, i As Long, p As String
c = ListFilesBy(r, ThisWorkbook.Path, "ノートA*")
If c = 0 Then Exit Sub
w = r
With CreateObject("Scripting.FileSystemObject")
For i = LBound(w) To UBound(w)
p = "_" & .GetFolder(.GetParentFolderName(w(i))).Name
w(i) = .GetBaseName(w(i)) & p & "." & .GetExtensionName(w(i))
w(i) = ThisWorkbook.Path & "\保存フォルダ\" & w(i)
Next
End With
FileCopyByFO r, w
End Sub
（白茶） 2018/09/27(木) 21:57
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.