Excel VBA質問箱 IV

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

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


9960 / 76734 ←次へ | 前へ→

【72329】Re:捺印数の照合
発言  ピッポ  - 12/7/12(木) 18:12 -

引用なし
パスワード
   お世話になります。

様々な指摘に関して感謝申し上げます。

・まず、何度か申し上げている通り、シート指定が1枚であれ複数枚であれ、処理を分ける必要はありません。
> すべてそのブックに対して For インデックス = 1 To シート数 で処理すれば、
> 1 To 1 あるいは 1 To 3 といったようにできますので。


おっしゃる通りです。
言い訳がましい言い方ですが、マクロに関して最近勉強し始めた為、発想力が乏しいもので・・・
様々なものに挑戦して応用力を身につけられるように努力します。

・ただ、なぜ、ピッポさんが、1かそうじゃないかに、こだわるんだろうと、考えてみました。
> もしかして・・・アップ済みのコード(オリジナルのピッポさんのコードロジックから想像したもの)では
> たとえば 捺印数指定が 4 、シート数が 3 。この場合、これら3つのシートがすべて、それぞれ 4つの捺印が必要。
> こんなロジックになっていました。でも、この 3つのシートの捺印数をあわせて、4 ということだったのかなと。
> 以下のコードは、その新しい解釈によるコードになっています。(元戻しはたやすいので、違っていれば指摘願います)

私の表現の仕方が曖昧だったと思います。

「捺印数指定が 4 、シート数が 3 」

シートが3つあり、それぞれのシートで4つづつ捺印してあることを意味しています。
自分なりに数ヶ所変更してみました。

動作確認した結果、問題ありませんでしたが、
UO3 さん的には何か別の方法の方が宜しいでしょうか?
ご意見頂ければ幸いです。


変更箇所を下記のコメントを明記
※訂正箇所になります
※追加箇所になります


Sub image_count()
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 nosSheet 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 シート数        
                  nosSheet = nosSheet + 1         ’※追加箇所になります
                    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
                    If i2 = 捺印数 Then okBooks = okBooks + 1 ’※追加箇所になります
                    i2 = 0                  ’※追加箇所になります  
                  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 & " 件)"
      ElseIf nosSheet <> okBooks Then
        rmks = rmks & "(捺印数不合ブック数:" & nosSheet - 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


・また、ロジックをシンプルにするために、指定フォルダの全ブックの全シートをチェックするようにしました。
> 従来のコードは、フォルダごとに問題あり/なしをセットするわけですから、1枚でもおかしなシートがあれば
> その時点で、ループを抜けるようになっていました。このほうが、かっこいいロジックなんですが、ループ制御の
> コードが煩雑・複雑になり、今後、ピッポさんが改造されるとこを考えて、素直というか愚直なロジックにしました。


ご配慮に感謝致します。
大した改造はできませんが、まずはコードの中身を理解したいと
思います。


>・ちょっと気になりましたので、問題ありの場合、どういう問題だったのかの補
>足も表示しました。
> でも、運用面としては、それじゃ、そのフォルダのどのブックが具体的に問題
>があったのか という質問が利用者から
> でた場合、それはわかりませんね。そういう必要があるなら、ブック明細を別
>表で作成するのがいいかもしれませんね。


運用面の方も想定して作成して頂き、大変助かりました。
確かに、何が問題あるのか明確化した方が問題有りの時の確認作業の合理化
にも繋がり参考になる技法だと思いました。
ブック明細は検討したいと思います。

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

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