Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

10059 / 76734

←次へ　｜　前へ→


	【72228】捺印数の照合

ピッポ - 12/6/24(日) 0:07 -


	引用なし

	パスワード

シート１のＦ列にハイパーリンクが設定されており、
ハイパーリンク先のフォルダにエクセルファイルが格納されています。
エクセルファイルを開くと、電子印が捺印されています。
シート１のＡＦ列に電子印の捺印数が記載されていて数が一致していれば
Ｉ列に”問題なし”、異常なら”問題あり”と記載したい。

下記のように作成しましたが、”問題あり”と記載されてしまいます。

ご教授頂けませんでしょうか？

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

3 hits

▼

【72228】捺印数の照合 ピッポ 12/6/24(日) 0:07

≪