| |
▼ピッポ さん：
要件に合っているかどうか、試してみてください。
Sub Sample2()
Dim myFso As Object
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim c As Range
Dim ans As String
Dim oFold As String
Dim nFold As String
Dim fName As String
Dim tName As String
Dim i As Long
Dim cnt As Long
Dim myPrefix As String
Dim mySuffix As String
Dim myCheck As String
Dim myFile As Object
Dim b As String
Dim e As String
mySuffix = "済"
myCheck = "毎月"
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("一覧表（フォーマット）")
Set sh2 = Sheets("元保管場所")
For Each c In sh2.Range("B2", sh2.Range("B" & sh2.Rows.Count).End(xlUp))
myPrefix = c.Value
i = c.Row
fName = ""
'一覧表 Ｅ列に 毎月 と記入あるものだけ
If sh1.Cells(i, "E").Value = myCheck Then
'元保管場所C列にハイパーリンクあるものだけ
If c.Offset(, 1).Hyperlinks.Count > 0 Then
oFold = c.Offset(, 1).Hyperlinks(1).Address
'一覧表C列にハイパーリンクあるものだけ
If sh1.Cells(i, "C").Hyperlinks.Count > 0 Then
nFold = sh1.Cells(i, "C").Hyperlinks(1).Address
'移動前フォルダ、移動後フォルダが存在するものだけ
If myFso.folderExists(oFold) And myFso.folderExists(nFold) Then
For Each myFile In myFso.GetFolder(oFold).Files
e = LCase(myFso.getextensionname(myFile.Name))
b = myFso.getbasename(myFile.Name)
'xls のみ
If e = "xls" Then
'指定文字列から始まり、"済"でおわっているもののみ
If b Like myPrefix & "*" & mySuffix Then
fName = myFile.Name
'移動先ブック名の生成
tName = Left(b, Len(b) - Len(mySuffix)) & "." & e
Exit For
End If
End If
Next
End If
End If
End If
End If
With sh1.Cells(i, "I")
'移動前フォルダに指定のブックが存在した場合のみ
If Len(fName) > 0 Then
If myFso.fileExists(nFold & "\" & tName) Then myFso.DeleteFile nFold & "\" & tName, Force:=True
myFso.MoveFile oFold & "\" & fName, nFold & "\" & tName
cnt = cnt + 1
.Value = "問題なし"
Else
.Value = "問題あり"
End If
End With
Next
Set myFso = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox cnt & " 個のファイルを「Svr→書庫」に移動しました。", vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
