|
シート1のF列にハイパーリンクが設定されており、
ハイパーリンク先のフォルダにエクセルファイルが格納されています。
エクセルファイルを開くと、電子印が捺印されています。
シート1のAF列に電子印の捺印数が記載されていて数が一致していれば
I列に”問題なし”、異常なら”問題あり”と記載したい。
下記のように作成しましたが、”問題あり”と記載されてしまいます。
ご教授頂けませんでしょうか?
Option Explicit
Sub image_count()
Dim myFso As Object
Dim MyOb 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 i As Long
Dim n As Long
Dim myFile As Object
Dim i1 As Long
Dim i2 As Long
Dim b As String
Dim e As String
Dim y As String
Dim 捺印数 As String
Dim cnt As Long
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
fName = ""
'F列にハイパーリンクなければスキップ
If c.Offset(, 0).Hyperlinks.Count > 0 Then
oFold = c.Offset(, 0).Hyperlinks(1).Address
'リンク先フォルダが存在するものだけ
If myFso.folderExists(oFold) Then
For Each myFile In myFso.GetFolder(oFold).Files
e = LCase(myFso.getextensionname(myFile.Name))
'b = myFso.getbasename(myFile.Name)
捺印数 = Cells(i, 32)
If e = "xls" Then
'If b Like "*" Then
fName = myFile.Name
'ブックオープンし、リンク先フォルダのxlsファイルに図形があるか判定
Workbooks.Open oFold & "\" & fName
With sh1.Cells(i, "J")
y = Workbooks(2).Sheets.Count
If y >= 2 Then
For n = 1 To y
Sheets(n).Select
i1 = 0
i2 = 0
Range("A1:BV9").Select 'シートの検索範囲を指定
With ActiveSheet
For Each MyOb In .Shapes 'drop downは対象外にする
If MyOb.Type <> 8 Then 'このifが無いとdrop存在時エラーが発生する
If Not Intersect(MyOb.TopLeftCell, Selection) Is Nothing Then
'左上角指定で選択されたシートのみを対象にする
'このifが無いとシート全体が対象になる
i1 = i1 + 1
Select Case MyOb.Type
Case msoPicture
i2 = i2 + 1
End Select
End If
End If
Next
End With
'MsgBox ("選択範囲内のDrawingObjectの数:" & i1)
'MsgBox ("選択範囲内のpicterの数:" & i2)
If i2 = 捺印数 Then
Else
GoTo NG
End If
Next n
'Application.Run "sheets_count"
End If
i1 = 0
i2 = 0
Range("A1:BV9").Select 'シートの検索範囲を指定
With ActiveSheet
For Each MyOb In .Shapes
If MyOb.Type <> 8 Then
If Not Intersect(MyOb.TopLeftCell, Selection) Is Nothing Then
i1 = i1 + 1
Select Case MyOb.Type
Case msoPicture
i2 = i2 + 1
End Select
End If
End If
Next
End With
'MsgBox ("選択範囲内のDrawingObjectの数:" & i1)
'MsgBox ("選択範囲内のpicterの数:" & i2)
If i2 = 捺印数 Then
ActiveWorkbook.Close savechanges:=False
.Value = "問題なし"
.Font.ColorIndex = 1
Else
NG:
ActiveWorkbook.Close savechanges:=False
.Value = "問題あり"
.Font.ColorIndex = 3
End If
End With
End If
Next
End If
End If
Next
Set myFso = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox cnt & " 個のファイルが捺印されています。", vbInformation
End Sub
|
|