Excel VBA質問箱 IV

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

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


10059 / 76734 ←次へ | 前へ→

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

引用なし
パスワード
   シート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

2 hits

【72228】捺印数の照合 ピッポ 12/6/24(日) 0:07 質問
【72233】Re:捺印数の照合 UO3 12/6/24(日) 8:23 発言
【72237】Re:捺印数の照合 UO3 12/6/24(日) 9:59 発言
【72238】Re:捺印数の照合 ピッポ 12/6/24(日) 14:25 回答
【72239】Re:捺印数の照合 UO3 12/6/24(日) 14:49 発言
【72241】Re:捺印数の照合 ピッポ 12/6/25(月) 0:25 お礼
【72276】Re:捺印数の照合 ピッポ 12/7/7(土) 9:42 発言
【72279】Re:捺印数の照合 UO3 12/7/7(土) 17:34 発言
【72281】Re:捺印数の照合 ピッポ 12/7/8(日) 11:39 発言
【72282】Re:捺印数の照合 UO3 12/7/8(日) 16:18 発言
【72284】Re:捺印数の照合 ピッポ 12/7/8(日) 16:47 発言
【72286】Re:捺印数の照合 UO3 12/7/8(日) 18:44 発言
【72283】Re:捺印数の照合 UO3 12/7/8(日) 16:35 発言
【72285】Re:捺印数の照合 ピッポ 12/7/8(日) 18:15 発言
【72287】Re:捺印数の照合 UO3 12/7/8(日) 20:54 発言
【72288】Re:捺印数の照合 UO3 12/7/9(月) 10:29 発言
【72294】Re:捺印数の照合 ピッポ 12/7/9(月) 18:00 発言
【72298】Re:捺印数の照合 UO3 12/7/10(火) 12:31 発言
【72329】Re:捺印数の照合 ピッポ 12/7/12(木) 18:12 発言
【72334】Re:捺印数の照合 UO3 12/7/13(金) 9:45 発言
【72339】Re:捺印数の照合 ピッポ 12/7/14(土) 21:26 お礼
【72299】Re:捺印数の照合 UO3 12/7/10(火) 12:42 発言

10059 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free