| |
お世話になります。
様々な指摘に関して感謝申し上げます。
・まず、何度か申し上げている通り、シート指定が１枚であれ複数枚であれ、処理を分ける必要はありません。
> すべてそのブックに対して For インデックス = 1 To シート数 で処理すれば、
> 1 To 1 あるいは 1 To 3 といったようにできますので。
おっしゃる通りです。
言い訳がましい言い方ですが、マクロに関して最近勉強し始めた為、発想力が乏しいもので・・・
様々なものに挑戦して応用力を身につけられるように努力します。
・ただ、なぜ、ピッポさんが、１かそうじゃないかに、こだわるんだろうと、考えてみました。
> もしかして・・・アップ済みのコード（オリジナルのピッポさんのコードロジックから想像したもの）では
> たとえば 捺印数指定が 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列定義、ＯＫ
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 & " 個のファイルの捺印状況がＯＫでした。", vbInformation
End Sub
・また、ロジックをシンプルにするために、指定フォルダの全ブックの全シートをチェックするようにしました。
> 従来のコードは、フォルダごとに問題あり／なしをセットするわけですから、１枚でもおかしなシートがあれば
> その時点で、ループを抜けるようになっていました。このほうが、かっこいいロジックなんですが、ループ制御の
> コードが煩雑・複雑になり、今後、ピッポさんが改造されるとこを考えて、素直というか愚直なロジックにしました。
ご配慮に感謝致します。
大した改造はできませんが、まずはコードの中身を理解したいと
思います。
>・ちょっと気になりましたので、問題ありの場合、どういう問題だったのかの補
>足も表示しました。
> でも、運用面としては、それじゃ、そのフォルダのどのブックが具体的に問題
>があったのか という質問が利用者から
> でた場合、それはわかりませんね。そういう必要があるなら、ブック明細を別
>表で作成するのがいいかもしれませんね。
運用面の方も想定して作成して頂き、大変助かりました。
確かに、何が問題あるのか明確化した方が問題有りの時の確認作業の合理化
にも繋がり参考になる技法だと思いました。
ブック明細は検討したいと思います。
|
|
ピッポ
- 12/7/12(木) 18:12 -
