| |
▼ピッポ さん：
要件を誤解しているところがあるかもしれませんが・・・・
シート１、シート２のＣ列のハイパーリンクは「フォルダ」までの指定との前提です。
（ブックまでの指定であれば、また別のコードになります）
Sub Sample()
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 ok As Boolean
Dim i As Long
Dim cnt As Long
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
ans = "済"
For Each c In sh2.Range("B2", 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"
If myFso.folderExists(oFold) Then
Workbooks.Open oFold & "\" & fName
check = Worksheets(1).Range("A500").Value
ActiveWorkbook.Close savechanges:=False
If check <> ans Then
If sh1.Cells(i, "C").Hyperlinks.Count > 0 Then 'C列にはーパーリンクなければスキップ
nFold = sh1.Cells(i, "C").Hyperlinks(1).Address
If myFso.folderExists(nFold) Then
If myFso.fileExists(nFold & "\" & fName) Then myFso.DeleteFile nFold & "\" & fName, Force:=True
myFso.MoveFile oFold & "\" & fName, nFold & "\" & fName
ok = True
cnt = cnt + 1
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 & " 個のファイルを「Svr→書庫」に移動しました。", vbInformation
End Sub
|
|
UO3
- 11/11/12(土) 23:07 -
