Excel VBA質問箱 IV

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

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


10048 / 76734 ←次へ | 前へ→

【72239】Re:捺印数の照合
発言  UO3  - 12/6/24(日) 14:49 -

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

こんにちは

アップされたコードそのままで上で申し上げたようなことを加味してみました。
拡張子を限定するならDIR関数のほうがやや使いやすいとも思いますが、とりあえずFSOのまま。
で、私が書くとすれば、さらにシェープの場所のチェックのループを無くしたものにするかもしれませんが
とりあえず。cntには、オリジナルのコードのとおり、何もセットしていません。
また、問題有り、なしの条件はオリジナルコードから推測して、たぶん、こんな分岐だろうとあたりをつけていますが
勘違いあれば指摘してください。

Sub Sample()
  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 cnt As Long
  Dim fWb As Workbook
  Dim fSh As Worksheet
  
  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
    With sh1.Range("J" & i)
      .ClearContents
      .Font.ColorIndex = xlAutomatic
    End With
    fName = ""
    'F列にハイパーリンクなければスキップ
    If c.Hyperlinks.Count > 0 Then
      oFold = ThisWorkbook.Path & "\" & c.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
            'ブックオープンし、リンク先フォルダの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
        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
1 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 発言

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