つExcel.マクロ.VBお助けください。

エクセルでマクロを組んでいます
別ファイルの指定した個所の値を取り込みたいです。

途中までは動いているのですが指定した個所の値ではなく、
なぜか空白になってしまっています。

ソースがこちらです。

Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
    ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With
    
    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 3
    
    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
    
    Call FileSearch(folderpass, "*.xls*")
    Dim dateupdate As String
    dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
    ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
    ThisWorkbook.Worksheets(2).Name = dateupdate
    ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
    ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)
    Dim i As Long
    Dim j As Long
    Dim openbook As Workbook
    Dim openbooksheet As Worksheet
    Application.ScreenUpdating = False
    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)
    '一覧化コピペ
    For i = 1 To openbook.Worksheets.Count
        Set openbooksheet = openbook.Worksheets(1)
        Dim blof As Variant
        ReDim blofar(0 To 1)
        For j = 0 To UBound(blof)
            blofar(j) = Trim(blof(j))
        Next j
        If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> "1" Then
           
             
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
                    
                    
                   
                    gyo2 = gyo2 + 1
        End If
        
    Next i
    
    openbook.Close False
    Application.ScreenUpdating = True
    Exit Sub
myError:
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub

どこまで動いているか確認するために
取り込む側の3行目に適当な値を入れて実行してみたところ、
途中までが空白セルに書き変わり、最後の数セルだけ指定した部分が空白になっていました。
昔別件でつかっていたマクロを改良して使いたかったのでポイントで直して、足して、消して、とやっていく間にどこを修正していいかわからなくなりました。
初心者で言葉足らずですが、ここはいらない、ここが足りない等お言葉を下さい。
よろしくお願いします。
追記
あまりにも言葉足らずでしたので追記します。
複数個のデータ（1シート目に取り込みたいデータがある）が入ったフォルダ（取り込まれる側）を選択し、取り込む側の2シート目に出力すというマクロです。
取り込む側のシート構成は１シート目に取り込んだデータのタイトルが並ぶ役割を、2シート目には指定したデータを集計する欄を作ってあります。
1シート目のタイトルは出てくるのですが、2シート目の集計シートに指定したセルのデータがなぜか入らないという状況です。よろしくお願いします。
追記２
どこまでデータが上書きされるのか確認するために
1-57(A-BE)に適当な値を入れてマクロを起動すると
1-45(A-AS)は空白に書き換わり
46-57(AT-BE)は値が入ったままになっています。
追記３

このようなメッセージが出ました。
隠れていたシートがありそこを指定していた間違いを修正しました。
ですが、追記２の部分が未だに謎のままです。
あと少しお力添えをお願いします。

追記４
マクロを起動すると取り込まれる側のエクセルデータが立ち上がるのですが自動的に消える処理まで到達していないことが分かりました。相変わらずデータの取得はできていません。原因解明の手口となればよいのですが…調べても原因解明に至っておりません。言葉足らずで頼ってばかりで申し訳ありませんがよろしくお願いします。

追記５

ttyp03さん用

お礼

皆さまのお力添えあって解決することができました！！！
ベストアンサーをお二方で悩みましたが
jawaさんとさせていただきます。
ttypさん、jawaさん本当にありがとうございました。

Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
    ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    ThisWorkbook.Worksheets(2).Range("A3:BE3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With
    
    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 3
    
    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
    
    Call FileSearch(folderpass, "*.xls*")
    Dim dateupdate As String
    dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
    ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
    ThisWorkbook.Worksheets(2).Name = dateupdate
    ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
    ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)


    Dim openbook As Workbook
    Dim openbooksheet As Worksheet

    Application.ScreenUpdating = False

    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)



        Set openbooksheet = openbook.Worksheets(1)
        openbooksheet.Unprotect
        


        Dim strMsg As String    'デバッグ用メッセージ
        strMsg = ""

        If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> 1 Then
                    'シートに書き出し
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
                    ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")

                   
                    gyo2 = gyo2 + 1
        End If

       
        MsgBox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg

  
    openbook.Close False

    Application.ScreenUpdating = True
    Exit Sub
myError:
    MsgBox Err.Description
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub

同じような躓き方をする方がいましたら使ってください。
現在動いている最終形態です。

masaya_ohashi

2016/06/14 02:49

質問文の```が、末尾にはありますがコードの先頭にないようです。修正してみてください。

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

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

気になったこと

追記を受けて

追加で気になったこと

全体ソース

関連した質問