Excel VBA質問箱 IV

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

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


9991 / 76734 ←次へ | 前へ→

【72298】Re:捺印数の照合
発言  UO3  - 12/7/10(火) 12:31 -

引用なし
パスワード
   ▼ピッポ さん:

こんにちは

コードをアップしますが、コメントを少々。

・まず、何度か申し上げている通り、シート指定が1枚であれ複数枚であれ、処理を分ける必要はありません。
 すべてそのブックに対して For インデックス = 1 To シート数 で処理すれば、
 1 To 1 あるいは 1 To 3 といったようにできますので。
・ただ、なぜ、ピッポさんが、1かそうじゃないかに、こだわるんだろうと、考えてみました。
 もしかして・・・アップ済みのコード(オリジナルのピッポさんのコードロジックから想像したもの)では
 たとえば 捺印数指定が 4 、シート数が 3 。この場合、これら3つのシートがすべて、それぞれ 4つの捺印が必要。
 こんなロジックになっていました。でも、この 3つのシートの捺印数をあわせて、4 ということだったのかなと。
 以下のコードは、その新しい解釈によるコードになっています。(元戻しはたやすいので、違っていれば指摘願います)
・また、ロジックをシンプルにするために、指定フォルダの全ブックの全シートをチェックするようにしました。
 従来のコードは、フォルダごとに問題あり/なしをセットするわけですから、1枚でもおかしなシートがあれば
 その時点で、ループを抜けるようになっていました。このほうが、かっこいいロジックなんですが、ループ制御の
 コードが煩雑・複雑になり、今後、ピッポさんが改造されるとこを考えて、素直というか愚直なロジックにしました。
・ちょっと気になりましたので、問題ありの場合、どういう問題だったのかの補足も表示しました。
 でも、運用面としては、それじゃ、そのフォルダのどのブックが具体的に問題があったのか という質問が利用者から
 でた場合、それはわかりませんね。そういう必要があるなら、ブック明細を別表で作成するのがいいかもしれませんね。

ともあれ、以下。
あまり十分なテストはしていませんし要件の誤解も、まだまだ多々あるかもしれませんがお試しください。

Sub Sample2()
  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 Variant    '★データ型は念のためVariant
  Dim シート数 As Variant   '★データ型は念のためVariant
  Dim y As Long
  Dim fWb As Workbook
  Dim fSh As Worksheet
  Dim cnt As Long
  Dim sid As Long
  Dim fdFound As Boolean
  Dim nosBooks As Long
  Dim okBooks As Long
  Dim okSpec As Boolean
  Dim rmks As String
  Dim mycIndex As Long
  
  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
    シート数 = sh1.Range("AG" & i).Value  'データ数もここで
    With sh1.Range("J" & i)
      .Clear   ' このほうがいいね
    End With
    
    fdFound = False
    okSpec = False
    nosBooks = 0
    okBooks = 0
    
    'F列にハイパーリンクなければスキップ
    If c.Hyperlinks.Count > 0 Then
      'ラインごとの変数初期化
      oFold = c.Offset(, 0).Hyperlinks(1).Address
      'リンク先フォルダが存在するものだけ
      If myFso.FolderExists(oFold) Then
        If IsNumeric(捺印数) And IsNumeric(シート数) Then  '念のため
          If 捺印数 > 0 And シート数 > 0 Then       'これも念のため
            okSpec = True                'AG/AF列定義、OK
            
            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)
                nosBooks = nosBooks + 1
                
                If シート数 <= fWb.Worksheets.Count Then  '指定シート数が存在する場合のみ
                  i2 = 0             '● ブック内捺印数カウンター
                  For sid = 1 To シート数         '指定シート数だけループ
                    Set fSh = fWb.Sheets(sid)
                    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
                  Next
                End If
                
                fWb.Close False
                If i2 = 捺印数 Then okBooks = okBooks + 1
                i2 = 0
                
              End If
             
            Next
            
          End If
        End If
      End If
      
      'フォルダ内検索終了
      
      cnt = cnt + okBooks
      rmks = "問題あり"
      mycIndex = 3
      
      If Not okSpec Then
        rmks = rmks & "(AF/AG列 不正)"
      ElseIf fdFound Then
        rmks = rmks & "(フォルダなし)"
      ElseIf nosBooks = 0 Then
        rmks = rmks & "(フォルダにブックなし)"
      ElseIf nosBooks <> okBooks Then
        rmks = rmks & "(捺印数不合ブック数:" & nosBooks - okBooks & " 件)"
      Else
        rmks = "問題なし"
        mycIndex = xlAutomatic
      End If
      
      With sh1.Range("J" & i)
        .Value = rmks
        .Font.ColorIndex = mycIndex
      End With
      
    End If
    
  Next

  Application.ScreenUpdating = True

  MsgBox cnt & " 個のファイルの捺印状況がOKでした。", vbInformation

End Sub

9 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 発言

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