| |
▼ピッポ さん：
こんにちは
アップされたコードそのままで上で申し上げたようなことを加味してみました。
拡張子を限定するならDIR関数のほうがやや使いやすいとも思いますが、とりあえずＦＳＯのまま。
で、私が書くとすれば、さらにシェープの場所のチェックのループを無くしたものにするかもしれませんが
とりあえず。cntには、オリジナルのコードのとおり、何もセットしていません。
また、問題有り、なしの条件はオリジナルコードから推測して、たぶん、こんな分岐だろうとあたりをつけていますが
勘違いあれば指摘してください。
Sub Sample()
Dim myFso As Object
Dim MyOb As Object
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim c As Range
Dim oFold As String
Dim fName As String
Dim i As Long
Dim myFile As Object
Dim i2 As Long
Dim e As String
Dim 捺印数 As String
Dim cnt As Long
Dim fWb As Workbook
Dim fSh As Worksheet
Application.ScreenUpdating = False
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("一覧表")
Set sh2 = Sheets("元保管場所(データベース）")
For Each c In sh1.Range("F11", sh1.Range("F" & sh1.Rows.Count).End(xlUp))
i = c.Row
捺印数 = sh1.Range("AF" & i).Value
With sh1.Range("J" & i)
.ClearContents
.Font.ColorIndex = xlAutomatic
End With
fName = ""
'F列にハイパーリンクなければスキップ
If c.Hyperlinks.Count > 0 Then
oFold = ThisWorkbook.Path & "\" & c.Hyperlinks(1).Address
'リンク先フォルダが存在するものだけ
If myFso.FolderExists(oFold) Then
For Each myFile In myFso.GetFolder(oFold).Files
e = LCase(myFso.getextensionname(myFile.Name))
If e = "xls" Then
fName = myFile.Name
'ブックオープンし、リンク先フォルダのxlsファイルに図形があるか判定
Set fWb = Workbooks.Open(oFold & "\" & fName)
For Each fSh In fWb.Worksheets
i2 = 0
For Each MyOb In fSh.Shapes '
If MyOb.Type = msoPicture Then '
If Not Intersect(MyOb.TopLeftCell, fSh.Range("A1:BV9")) Is Nothing Then
'左上角指定で選択されたシートのみを対象にする
'このifが無いとシート全体が対象になる
i2 = i2 + 1
End If
End If
Next
fWb.Close False
If i2 <> 捺印数 Then Exit For
Next
If i2 <> 捺印数 Then Exit For
End If
Next
With sh1.Range("J" & i)
.Value = "問題" & IIf(i2 = 捺印数, "なし", "あり")
.Font.ColorIndex = IIf(i2 = 捺印数, xlAutomatic, 3)
End With
End If
End If
Next
Application.ScreenUpdating = True
MsgBox cnt & " 個のファイルが捺印されています。", vbInformation
End Sub
|
|
UO3
- 12/6/24(日) 14:49 -
