| |
▼ピッポ さん：
こんにちは
コードをアップしますが、コメントを少々。
・まず、何度か申し上げている通り、シート指定が１枚であれ複数枚であれ、処理を分ける必要はありません。
すべてそのブックに対して For インデックス = 1 To シート数 で処理すれば、
1 To 1 あるいは 1 To 3 といったようにできますので。
・ただ、なぜ、ピッポさんが、１かそうじゃないかに、こだわるんだろうと、考えてみました。
もしかして・・・アップ済みのコード（オリジナルのピッポさんのコードロジックから想像したもの）では
たとえば 捺印数指定が 4 、シート数が 3 。この場合、これら3つのシートがすべて、それぞれ 4つの捺印が必要。
こんなロジックになっていました。でも、この 3つのシートの捺印数をあわせて、4 ということだったのかなと。
以下のコードは、その新しい解釈によるコードになっています。（元戻しはたやすいので、違っていれば指摘願います）
・また、ロジックをシンプルにするために、指定フォルダの全ブックの全シートをチェックするようにしました。
従来のコードは、フォルダごとに問題あり／なしをセットするわけですから、１枚でもおかしなシートがあれば
その時点で、ループを抜けるようになっていました。このほうが、かっこいいロジックなんですが、ループ制御の
コードが煩雑・複雑になり、今後、ピッポさんが改造されるとこを考えて、素直というか愚直なロジックにしました。
・ちょっと気になりましたので、問題ありの場合、どういう問題だったのかの補足も表示しました。
でも、運用面としては、それじゃ、そのフォルダのどのブックが具体的に問題があったのか という質問が利用者から
でた場合、それはわかりませんね。そういう必要があるなら、ブック明細を別表で作成するのがいいかもしれませんね。
ともあれ、以下。
あまり十分なテストはしていませんし要件の誤解も、まだまだ多々あるかもしれませんがお試しください。
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列定義、ＯＫ
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 & " 個のファイルの捺印状況がＯＫでした。", vbInformation
End Sub
|
|
UO3
- 12/7/10(火) 12:31 -
