| |
昨日はお世話になりました。
一つだけ教えて頂きたいのですが、
ファイル名が存在しない、ファイル名が違う場合は、移動しない。かつ
問題ありと表示させたいのですが、教えて頂けませんでしょうか？
""記録名"&"***"&"済"&".xls"だけ移動したい。
Sub 転送()
Dim myFso As Object
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim c As Range
Dim ans As String
Dim check As String
Dim oFold As String
Dim nFold As String
Dim fName As String
Dim fName2 As String
Dim ok As Boolean
Dim i As Long
Dim cnt As Long
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("一覧表（フォーマット）")
Set sh2 = Sheets("元保管場所")
ans = "済"
ans1 = "毎月"
For Each c In sh2.Range("B7", sh2.Range("B" & sh2.Rows.Count).End(xlUp))
ok = False
i = c.Row
If c.Offset(, 1).Hyperlinks.Count > 0 Then 'C列にハイパーリンクなければスキップ
oFold = c.Offset(, 1).Hyperlinks(1).Address
fName = c.Value & ".xls"
fName2 = c.Value & ans & ".xls" 'ファイル名&済.xlsを取得
If myFso.folderExists(oFold) Then
'Workbooks.Open oFold & "\" & fName2
'check = Worksheets(1).Range("A500").Value
'ActiveWorkbook.Close savechanges:=False
'If check = ans Then 'If check <> ans Then
If sh1.Cells(i, "F").Hyperlinks.Count > 0 Then 'F列にハイパーリンクなければスキップ
nFold = sh1.Cells(i, "F").Hyperlinks(1).Address
If myFso.folderExists(nFold) Then
If sh1.Cells(i, "E") = ans1 Then
If myFso.fileExists(nFold & "\" & fName) Then myFso.DeleteFile nFold & "\" & fName, Force:=True
myFso.MoveFile oFold & "\" & fName2, nFold & "\" & fName
ok = True
cnt = cnt + 1
End If
End If
End If
'End If
End If
End If
End If
With sh1.Cells(i, "I")
If ok Then
.Value = "問題なし"
Else
.Value = "問題あり"
End If
End With
Next
Set myFso = Nothing
MsgBox cnt & " 個のファイルを「指定された書庫」に移動しました。", vbInformation
End Sub
|
|
ピッポ
- 11/11/13(日) 22:06 -
