質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.80%

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

解決済

回答 4

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 565

score 2

前提・実現したいこと

あるフォルダの中に同じフォーマットでブック名が異なる日報の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**

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

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

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • hatena19

    2020/06/02 11:47 編集

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

    キャンセル

  • hatena19

    2020/06/02 11:57 編集

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

    キャンセル

回答 4

+1

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+1

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

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


Closeも同様です。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

check解決した方法

0

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

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

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

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.80%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る