VBA 特定のブックのセルの値によって、別のブックのセルに入力したい

Question

前提・実現したいこと

あるフォルダの中に同じフォーマットでブック名が異なる日報のExcelが20個ぐらいあります。
それぞれのExcelから必要な部分のみ抽出して1つのExcelにまとめるプログラムを書いております。

その日報のExcelの特定のセルに"有り"と入力されていた時に、まとめているExcelの特定のシートに-500000と入力をさせたいのです。

発生している問題・エラーメッセージ

ファイル名を取得する際に以下のエラーが表示され止まってしまいます。

エラーメッセージ
実行時エラー '9'
インデックスが有効範囲にありません。

該当のソースコード

Sub test()

    Application.ScreenUpdating = False
    
    Dim file As String
    file = Dir(ThisWorkbook.Path & "*本体材料費*")
    
    Do While file <> ""
    
    Dim wb As Workbook
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & file)
    
    Sheets("本体材料費明細提出用（新仕切併用）").Select
    
    Dim i As Long
    For i = 22 To 36
        
        If Not Cells(i, 2) = "" And Not Cells(i, 2) = HasFormula Then
            Range(Cells(i, 15), Cells(i, 45)).Select
            Selection.Copy
            Exit For
        End If
    Next i
    
    ThisWorkbook.Activate
    
    Dim x As Long
    For x = 22 To 123
    
        If Cells(x, 2) = wb.Sheets("本体材料費明細提出用（新仕切併用）").Cells(i, 2) Then
            Cells(x, 15).PasteSpecial Paste:=xlPasteValues
            Exit For
        End If
    Next x
    
**    '以下のコードでエラーが発生します。
    If Workbooks(file).Sheets("商品名A").Range("AD28").Value = "有り" Then**
        Cells(x, 37).value = -500000
    End If
    
    Workbooks(file).Close savechanges:=False
    file = Dir
    
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "コピー完了しました。"
    
End Sub

試したこと

If Workbooks(file).Sheets("商品名A").Range("AD28").Value = "有り" Then**

を

If Workbooks**(ThisWorkbook.Path & "" & file).Sheets("商品名A").Range("AD28").Value = "有り" Then

にしましたが、同様の現象でした。

解決方法を教えていただけないでしょうか。

よろしくお願いいたします。

Comments

[hatena19]

コードは、コードブロックに入れてください。
コードを選択して、ツールバーの<code>ボタンをクリックです。

[hatena19]

あるいは、下記をコピーしてコードを入力してください。
```vba
ここにコードを入力
```

Answer 1

「商品名A」シートがあるのかまず確認。
あと折角Openしてwbにブックオブジェクトが入っているのだからそれを使いましょう。

If Workbooks(file).Sheets("商品名A").Range("AD28").Value = "有り" Then
↓
If wb.Sheets("商品名A").Range("AD28").Value = "有り" Then

Closeも同様です。

Answer 2

Sheets("商品名A")がうまく認識していないのかも知れません。
Sheets("商品名A")を、Worksheets("商品名A")に代えるとどうでしょうか？

Answer 3

エラーの原因がわかり、解決いたしましたので記載いたします。
みなさんの投稿から、見たいセルを見に行くコードは間違いえていない可能性が高いと思ったので
同じフォルダの中にある日報のブックを見返してみました。
AD28セルですが、AL28までセルが統合されており、それを解除したところ正しく動作するようになりました。

そこで
If Workbooks(file).Sheets("商品名A").Range("AD28").Value = "有り" Then**
を
If wb.Worksheets("商品名A").Range("AD28").MergeArea(1, 1).Value = "有り" Then
にした所、正しく動作するようになりました。

情報不足と確認不足でもうしわけありません。
回答いただきありがとうございました。

Answer 4

Excelコーディングのスキルアップの第一歩は、
アクティブなオブジェクトを対象に処理をするというコーディングから卒業することです。
つまり、SelectやSelectionを使わないということです。

Office TANAKA - VBA高速化テクニック[Selectしない]

提示のコードを上記の方針が書き替えたコード例です。

Sub test()

    Application.ScreenUpdating = False
    
    Dim file As String
    file = Dir(ThisWorkbook.Path & "*本体材料費*")
    
    Do While file <> ""
    
        Dim wb As Workbook
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & file)
        
        Dim ws As Worksheet
        Set ws = wb.Worksheets("本体材料費明細提出用（新仕切併用）")
        
        Dim i As Long
        For i = 22 To 36
        
            If Not ws.Cells(i, 2) = "" And Not ws.Cells(i, 2).HasFormula Then
                Dim v
                v = ws.Range(ws.Cells(i, 15), ws.Cells(i, 45)).Value
                Exit For
            End If
        Next i
        
               
        Dim x As Long
        For x = 22 To 123
            
            If ThisWorkbook.Cells(x, 2) = ws.Cells(i, 2) Then
                ThisWorkbook.Cells(x, 15).Value = v
                Exit For
            End If
        Next x
        
        If wb.Worksheets("商品名A").Range("AD28").Value = "有り" Then
            ThisWorkbook.Cells(x, 37).Value = -500000
        End If
        
        wb.Close savechanges:=False
        file = Dir
    
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "コピー完了しました。"

End Sub