各 Excel ファイルの記入モレをチェックしたい（画像含む）

頑張って目視チェックすると疲れるので、Excel に集めさせて、モレているかどうか判断してもらった方が正確だし、速いし、文句言わないし、とか、よくある VBA だと思うんですけど、そんなことない？

やりたかったことは、チェック対象の Excel を読み取り専用で開いて、チェックしたいデータや画像を持ってきて、一覧で目視チェックをする。というものです。実際には、フォルダ指定してその中にある Excel や Word を複数チェックするような仕様になるんだと思います。今回は1ファイルのみの指定でサンプルを書きました。

こんなシートの値を、

チェックシートに転記してきて、目視チェック！

目視チェックするのが嫌なのに、結局目視チェックするっていうのはどうかと思うので、実際には、ファイルのフルパスを追加して、空欄だったら背景色赤に塗ったり、NGとか書いたり、までを VBA でこしらえればいいですね～。

Private Sub CommandButton1_Click()
    
    Dim targetFile As String
    Dim targetBok As Workbook
    Dim targetSht As Worksheet
    Dim checkSht As Worksheet
    
    ' チェック対象のシートを読み込む、本シートも読み込む
    targetFile = ThisWorkbook.Path & "\aaa.xlsx"
    Set targetBok = Workbooks.Open(targetFile, , True)
    Set targetSht = targetBok.Worksheets("Sheet1")
    Set checkSht = ThisWorkbook.Worksheets("Sheet1")
    
    ' Target シートのデータ範囲
    Dim startIndex As Long
    Dim endIndex As Long
    
    startIndex = 1
    endIndex = targetSht.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' Check シートの現在位置
    Dim currentIndex As Long
    currentIndex = 1
    
    Dim s As Shape
    
    For i = startIndex To endIndex
        
        ' 更新日
        checkSht.range("A" + CStr(currentIndex)).Value = targetSht.range("A" + CStr(i)).Value
        
        ' 内容
        checkSht.range("B" + CStr(currentIndex)).Value = targetSht.range("B" + CStr(i)).Value
        
        ' 確認印
        ' 確認印のセル範囲内にある画像を探してきて、コピー貼り付けする
        Set s = GetImage(targetSht, targetSht.range("C" + CStr(i)))
        If s Is Nothing = False Then
            
            s.Copy
            checkSht.Activate
            checkSht.range("c" + CStr(i)).Select
            checkSht.Paste
            
            ' セルの中央寄せになるように移動
            Selection.Top = Selection.Top + (checkSht.range("c" + CStr(i)).Height - s.Height) / 2
            Selection.Left = Selection.Left + (checkSht.range("c" + CStr(i)).Width - s.Width) / 2
            
        End If
        
        currentIndex = currentIndex + 1
        
    Next
    
    targetBok.Close
    Set targetSht = Nothing
    Set checkSht = Nothing
    
End Sub

' 指定セル内にある画像を返却
Private Function GetImage(ByVal sht As Worksheet, ByVal r As range) As Shape
    
    Dim s As Shape
    
    For Each s In sht.Shapes
        
        ' 画像が、指定セル内の左上位置から右下位置の中に納まっているかをチェック
        If (r.Top <= s.Top) And (r.Left <= s.Left) And ((s.Left + s.Width) <= (r.Left + r.Width)) And ((s.Top + s.Height) <= (r.Top + r.Height)) Then
            Set GetImage = s
            Exit For
        End If
        
    Next
    
End Function