プロが教えるわが家の防犯対策術!

初心者ですエクセルマクロでデータ抽出したいですがファイルによって読込できません、何か問題ありますか?ちなみにファイル名は読み込めますが、データ読み込みでエラーになるようです。

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


Sub ExcelbookCombine()
'-------------------------------------------------------------------------------------------------------
'処理開始
'-------------------------------------------------------------------------------------------------------
MsgBox MESSAGE_START

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then Exit Sub
Fol = .SelectedItems(1)
End With

Dim Fn
' Dim NewFile As Workbook
Dim Wb As Workbook
'Dim Ws1 As Worksheet
Dim R As Range
Dim SrcRng As Range
Dim Rng As Range

'開始行の指定(データ最終行の次の行
Dim n
n = Cells(Rows.Count, 1).End(xlUp).Row + 1

'セットするシートの指定
Dim w
Set w = Worksheets(1)

'ファイル名(拡張子なし)を取得するためのFileSystemObjectオブジェクト - GetBaseNameメソッド
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

Set SrcRng = ActiveSheet.Range("B4")
Set Ws1 = Worksheets(1)
Set R = Ws1.Range("A2")
Fn = Dir(Fol & "\*.xls*")

Do Until Fn = ""

Set Wb = Workbooks.Open(Fol & "\" & Fn)
'ワークシート1をコピーする場合は Wb.Worksheets(1)
'Set Ws2 = Wb.Worksheets(3)
'
''
'各所の値をコピーしてa~gにセットする
' ActiveSheet.Unprotect
w.Range("a" & n).Value = FSO.getbasename(Fn)
'この下の行がエラー時に反転します
w.Range("c" & n).Value = Workbooks(Fn).Worksheets(3).Range("b3").Value
w.Range("d" & n).Value = Workbooks(Fn).Worksheets(3).Range("o6").Value
w.Range("e" & n).Value = Workbooks(Fn).Worksheets(2).Range("aa3").Value
w.Range("f" & n).Value = Workbooks(Fn).Worksheets("指定額").Range("cj3").Value
w.Range("g" & n).Value = Workbooks(Fn).Worksheets("指定額").Range("b5").Value
w.Range("h" & n).Value = Workbooks(Fn).Worksheets("指定額").Range("o5").Value
w.Range("i" & n).Value = Workbooks(Fn).Worksheets("指定額").Range("b7").Value
w.Range("j" & n).Value = Workbooks(Fn).Worksheets("指定額").Range("cj55").Value
w.Range("a" & n).Resize(1, 10).Borders.LineStyle = xlContinuous
n = n + 1
Workbooks(Fn).Close savechanges:=False

Fn = Dir
Loop
Range("A4").Select
MsgBox MESSAGE_FINISH
Set R = Nothing
Set Ws1 = Nothing: Set Ws2 = Nothing
Set Wb = Nothing: Set NewFile = Nothing


End Sub

A 回答 (2件)

こんにちは。



最初に、朝から、この質問は、何度か消えていませんか。
そのたびに内容は変わっていないといいのですが。
お急ぎなのは分かりますが、なかなか、すぐに返事出来ない時があります。

ざっと見た感じですが、コードはひどく雑ですが、特に問題になる部分はありません。

ただ、
Set Wb = Workbooks.Open(Fol & "\" & Fn)
となっているのですから、
 Wb.Worksheets(3).Range("b3").Value
 となりますね。

実行時エラー'9'
インデックスが有効範囲にありません
ということは、

Wb.Worksheets(3)
Wb.Worksheets(2)
Wb.Worksheets("指定額")

この3つの内、ないものがあるということです。シートの数なのか、「指定額」というシートかは分かりません。

以下のコードで書き加えた所をみてください。
また、
If num > 3 And TypeName(dummy) = "Worksheet" Then
これは多少工夫してください。

だから、フォルダーの中を全部のファイルをあたり、データを吸い上げるようにするには、以下のようにします。

'---中略----
 '各所の値をコピーしてa~gにセットする
    ' ActiveSheet.Unprotect
     Dim dummy As Variant  '←Variant型で指定
     Dim num As Long
    On Error Resume Next  '←エラートラップ
     num = Wb.Worksheets.Count
     Set dummy = Wb.Worksheets("指定額")
     If num > 3 And TypeName(dummy) = "Worksheet" Then 'シートの数と指定額のシートがあるか?
      With Wb
        w.Range("a" & n).Value = FSO.getbasename(Fn)
      
        w.Range("c" & n).Value = .Worksheets(3).Range("b3").Value
        w.Range("d" & n).Value = .Worksheets(3).Range("o6").Value
        w.Range("e" & n).Value = .Worksheets(2).Range("aa3").Value
        w.Range("f" & n).Value = .Worksheets("指定額").Range("cj3").Value
        w.Range("g" & n).Value = .Worksheets("指定額").Range("b5").Value
        w.Range("h" & n).Value = .Worksheets("指定額").Range("o5").Value
        w.Range("i" & n).Value = .Worksheets("指定額").Range("b7").Value
        w.Range("j" & n).Value = .Worksheets("指定額").Range("cj55").Value
        w.Range("a" & n).Resize(1, 10).Borders.LineStyle = xlContinuous
        n = n + 1
        .Close savechanges:=False
      End With
      Set dummy = Nothing
    Else
      Debug.Print Wb.Name  'ファイルの名前を残す(必要がなければこの行なし)
      Wb.Close False
    End If
    Fn = Dir
Loop

というようにしたらどうでしょう。
    • good
    • 0
この回答へのお礼

ありがとうございます!!
きっとできたと思います!
とりあえず読み込めたので
後でじっくり分析してみます!

急いでたので中身は変えずに更新していましたwすいません。。。

お礼日時:2016/06/07 19:15

返事ありがとうございます。



簡略化してみると分かるかと思います。

Do Until Fn = ""
ファイルを取得


Wb.Worksheets(3)
Wb.Worksheets(2)
Wb.Worksheets("指定額")

この条件を満たしているか。エラーの発生をチェックして、


エラートラップ(On Error ....)で捕まえて、

-エラーがないなら、中身を読む
-エラーが発生したら、中身を読まないようにする。


Fn = Dir
次のファイルを探す。
-Loop
という仕組みです。
    • good
    • 0
この回答へのお礼

そうですよね、初心者なので最短でやりたいことのみで構成しているので
こんなトラップとか神レベルです。

        w.Range("d" & n).Value = .Worksheets(3).Range("o6").Value
        w.Range("e" & n).Value = .Worksheets(2).Range("aa3").Value
        w.Range("f" & n).Value = .Worksheets("指定額").Range("cj3").Value

というのはエラーが出るのでシートの指定を色々と変えてみたので、こうなっていますw

でも、結局のところ、ご指摘のとおり

ただ、
Set Wb = Workbooks.Open(Fol & "\" & Fn)
となっているのですから、
 Wb.Worksheets(3).Range("b3").Value
 となりますね。

という部分が問題になっていただけな気がしました。
色々とかえて検証して勉強したいと思います。
本当にありがとうございました!助かります。

お礼日時:2016/06/08 07:18

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!