| |
お世話になります。
質問１：
シートが1つの場合は問題なく照合できたのですが
複数シートがある際、捺印数の照合した結果、”問題なし”としか
表示されないのですがどのうように訂正すればよろしいでしょうか？
質問２：
下記のコードの構造を教えて頂きたいのですが、図形（msoPicture）
があればi2に1が代入されるというのは理解できるのですが、なぜ
i2 <> 捺印数なのか理解できませんでした。
恐れ入りますがご指導頂ければ幸いです。
If Not Intersect(MyOb.TopLeftCell, fSh.Range("A1:BV9")) Is Nothing Then
i2 = i2 + 1
End If
End If
Next
fWb.Close False
If i2 <> 捺印数 Then Exit For
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 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 String
Dim シート数 As String
Dim y As Long
Dim fWb As Workbook
Dim fSh As Worksheet
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
With sh1.Range("J" & i)
.Font.ColorIndex = xlAutomatic
End With
fName = ""
'F列にハイパーリンクなければスキップ
If c.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))
If e = "xls" Then
fName = myFile.Name
シート数 = sh1.Range("AG" & i).Value
'ワークシート数が1つの場合
If シート数 = 1 Then
'ブックオープンし、リンク先フォルダのxlsファイルに図形があるか判定
Set fWb = Workbooks.Open(oFold & "\" & fName)
For Each fSh In fWb.Worksheets
i2 = 0
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
fWb.Close False
If i2 <> 捺印数 Then Exit For
Next
If i2 <> 捺印数 Then Exit For
End If
If シート数 >= 2 Then
'ブックオープンし、リンク先フォルダのxlsファイルに図形があるか判定
Set fWb = Workbooks.Open(oFold & "\" & fName)
For Each fSh In fWb.Worksheets
y = fWb.Sheets.Count
For n = 1 To y 'シート数分だけループ
Sheets(n).Select
i2 = 0
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 Exit For
Next
fWb.Close False
If i2 = 捺印数 Then Exit For
Next
End If
End If
Next
With sh1.Range("J" & i)
.Value = "問題" & IIf(i2 = 捺印数, "なし", "あり")
.Font.ColorIndex = IIf(i2 = 捺印数, xlAutomatic, 3)
End With
End If
End If
Next
Application.ScreenUpdating = True
MsgBox cnt & " 個のファイルが捺印されています。", vbInformation
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
