| |
なんだか良くわかりませんでしたが、
A列:元ファイル名, B列:新フォルダ名, C列：新ファイル名 と
並んでいると仮定して作ってみました。ALoopを実行してください。
ものすごく無駄の多いマクロな気がします・・・
'○A列で結合セル、空白セル以外を実行する。
Sub ALoop()
Dim i As Integer
For i = 1 To Worksheets(1).UsedRange.Rows.Count + 1
If Cells(i, 1).MergeCells = False Then
If Cells(i, 1).Value <> "" Then
Call FSearch(Cells(i, 1).Value, i)
End If
End If
Next i
End Sub
'○このファイル配下にファイルがあるか探す。
Sub FSearch(FName As String, i As Integer)
Dim MyPath As String
Dim c As Integer
MyPath = ThisWorkbook.Path
With Application.FileSearch
.NewSearch
.LookIn = MyPath
.SearchSubFolders = True
.Filename = FName
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For c = 1 To .FoundFiles.Count
If FName = Dir(.FoundFiles(c), vbNormal) Then
Call DTSerach(.FoundFiles(c), i)
Exit Sub
End If
Next c
End If
'ファイルがないのでA列に色を塗る
Cells(i, 1).Interior.ColorIndex = 3
End With
End Sub
'○デスクトップにB列のフォルダがあるか調べる。
'フォルダがあれば、フォルダ内にコピー。なければフォルダを作ってコピー
Sub DTSerach(OldFile As String, i As Integer)
Dim objFolder As Object
Dim objSub As Object
Dim WSH As Object
Dim DTPath As String
Dim MkPath As String
Set WSH = CreateObject("WScript.Shell")
DTPath = WSH.SpecialFolders("Desktop")
Set objFolder = CreateObject("Scripting.FileSystemObject").GetFolder(DTPath)
For Each objSub In objFolder.Subfolders
If Cells(i, 2).Value = objSub.Name Then
FileCopy OldFile, objSub & "\" & Cells(i, 3).Value
Exit Sub
End If
Next objSub
'フォルダがないので作成して中にコピー
MkPath = DTPath & "\" & Cells(i, 2).Value
MkDir (MkPath)
FileCopy OldFile, MkPath & "\" & Cells(i, 3).Value
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
