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

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

ただいまの
回答率

89.64%

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

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 2,594

teryyyyy2

score 15

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

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

ソースがこちらです。

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シート目に出力すというマクロです。
取り込む側のシート構成は1シート目に取り込んだデータのタイトルが並ぶ役割を、2シート目には指定したデータを集計する欄を作ってあります。
1シート目のタイトルは出てくるのですが、2シート目の集計シートに指定したセルのデータがなぜか入らないという状況です。よろしくお願いします。
追記2
どこまでデータが上書きされるのか確認するために
1-57(A-BE)に適当な値を入れてマクロを起動すると
1-45(A-AS)は空白に書き換わり
46-57(AT-BE)は値が入ったままになっています。
追記3

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

イメージ説明

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

追記5
イメージ説明
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


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

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

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

  • teryyyyy2

    2016/06/14 13:12

    これで大丈夫でしょうか…

    キャンセル

  • ttyp03

    2016/06/14 13:13

    OK!

    キャンセル

  • teryyyyy2

    2016/06/14 15:49

    情報を追記しましたのでお力添えをお願いします…。

    キャンセル

回答 3

checkベストアンサー

+2

どんなデータを読みとった時にどんな動作をするのか、
・期待する動作
・実際の動作
・対象フォルダの構成
が不明瞭なので的確なアドバイスができているかわかりませんが。

解析したところ、指定されたフォルダ配下(サブフォルダ含む)のExcelファイルを検索し、各シートの特定セルの内容を自ブックのシート2に書き出すVBAマクロだと思われます。

気になったこと

ソース上、気になる点がいくつかありました。
①全シート数分のループ処理をしているのに、読み込みシートは常にシート1でよいのか?

Set openbooksheet = openbook.Worksheets(1)  '(1)ではなく(i)では?

②配列でない変数を配列として扱っている為エラーが発生している ⇒不要な処理であれば削除する

Dim blof As Variant
        ReDim blofar(0 To 1)

        For j = 0 To UBound(blof)       'blofは配列ではないためエラー
            blofar(j) = Trim(blof(j))
        Next j

③行番号を文字列と比較しているが想定した判定結果となっているか?

If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> "1" Then     '<> "1"ではなく <> 1 ?

④全体的にほとんどコメントがないため、処理が読み取りにくい。
※自分が記述したコードでなくても、解析した部分に処理内容をコメント追加していくと解析しやすくなります。
※繰り返し使用しているThisWorkbook.Worksheets(1)等も、わかりやすい変数に格納したほうが読み取りやすくなります。
例:

'ファイル検索
Sub FileSearch(Path As String, Target As String)

    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")

    Dim wsStatusSheet As Worksheet  '状況出力シート
    Set wsStatusSheet = ThisWorkbook.Worksheets(1)

    '全てのサブフォルダをループ処理
    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
            'ファイル名がTargetに含まれる場合、処理対象
            filecount = filecount + 1
            wsStatusSheet.Cells(gyo, 1) = File.Name    'ファイル名を出力
            wsStatusSheet.Cells(gyo, 2) = File.Path    'ファイルパスを出力
            'コピー処理
            Call ParCopy(File.Path)

            gyo = gyo + 1
        End If
        wsStatusSheet.Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub

以上をなおすことで問題の現象が解決するという保証はありませんが、特に④を整理すれば解析はしやすくなると思います。

あとは
・異常な結果となる1ファイルだけを対象に処理しても同じ結果となるか?
⇒入力元のデータの問題か、繰り返し処理による問題かの判別
・ParCopy関数内にブレイクポイントを貼って、問題のファイルを読み込むあたりを重点的にデバッグする
⇒具体的に空セルがセットされるメカニズムを把握する
といった調査で原因を特定していけばよいと思います。


追記を受けて

やりたいことはおおよそ伝わりましたが、エラーの発生状況がまだよくわかりません。

コードが期待通りのロジックとなっているのなら、取り込まれる側シートのA70,R2,…AE48の内容を取り込む側シートの6,7,42,…56列目にコピーしたいのだと思います。
・これらすべてが空欄となるのか
・あるファイルの分はコピーできているが、あるファイルの分は空欄となってしまうのか

追加で気になったこと

コード内で読み取るシートを

Set openbooksheet = openbook.Worksheets(1)


と指定しています。
これで取得できるシートは、ブック内で一番左側のシートです。
これには非表示のシートも含まれますので、一番左のシートが非表示の場合、見えていないシートからデータを取得することになります。

以下に対象となっているシートと、セルの値を表示するサンプルを作成してみました。
⇒ 長くなりすぎたので全体ソースを参照してください。

これで状況を確認してみてください。

全体ソース

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")

    Dim wsStatusSheet As Worksheet  '状況出力シート
    Set wsStatusSheet = ThisWorkbook.Worksheets(1)

    '全てのサブフォルダをループ処理
    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
            'ファイル名がTargetに含まれる場合、処理対象
            filecount = filecount + 1
            wsStatusSheet.Cells(gyo, 1) = File.Name    'ファイル名を出力
            wsStatusSheet.Cells(gyo, 2) = File.Path    'ファイルパスを出力
            'コピー処理
            Call ParCopy(File.Path)

            gyo = gyo + 1
        End If
        wsStatusSheet.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

        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")

                    'デバッグ用メッセージに書き出し
                    strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
                    strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
                    strMsg = strMsg & "R2  :" & openbooksheet.Range("R2") & vbCr
                    strMsg = strMsg & "AC43:" & openbooksheet.Range("AC43") & vbCr
                    strMsg = strMsg & "AC44:" & openbooksheet.Range("AC44") & vbCr
                    strMsg = strMsg & "AC45:" & openbooksheet.Range("AC45") & vbCr
                    strMsg = strMsg & "AC46:" & openbooksheet.Range("AC46") & vbCr
                    strMsg = strMsg & "AE48:" & openbooksheet.Range("AE48") & vbCr
                    strMsg = strMsg & "AA2 :" & openbooksheet.Range("AA2") & vbCr
                    strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
                    strMsg = strMsg & "T22 :" & openbooksheet.Range("T22") & vbCr
                    strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr

                    gyo2 = gyo2 + 1
        End If

        '処理中のファイル名・シート名を画面表示する
        MsgBox "ファイル名:" & Path & vbCr & "シート名:" & openbooksheet.Name & vbCr & strMsg

    '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

このコードで、指定フォルダ配下の2ファイル、およびそのサブフォルダ配下の1ファイルからの情報取得を確認しています。

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2016/06/15 17:07

    一つ目に関しましては自分も試してみましたがだめでした…。
    二つ目に関しましては貼り付けが出来ました。
    空白になったわけではありませんでした。

    キャンセル

  • 2016/06/15 17:41

    保護を外すために
    Set openbooksheet = openbook.Worksheets(1)
    《openbooksheet.Unprotect》
    《》内を追加したところ
    プロシージャの呼び出し、または引数が不正です。
    とエラーが出たところです。

    キャンセル

  • 2016/06/15 17:47

    上記の部分に関しては解決しました!
    そしてマクロも無事動きました!!!!
    保護されていたのが問題だったようです。
    お力添えをいただき本当にありがとうございました!!!!

    キャンセル

+2

セル間でコピーしている参照しているセルの位置はあっているものとして、気になるのはワークシートを選択しているところでしょうか。

'一覧化コピペ 
For i = 1 To openbook.Worksheets.Count 
    Set openbooksheet = openbook.Worksheets(1)


ここのopenbook.Worksheets(1)のところを次のようにしたらどうでしょうか。

Set openbooksheet = openbook.Worksheets(i)


シートの構成がわからないので勘ですが…。

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2016/06/15 17:40

    保護を外すために
    Set openbooksheet = openbook.Worksheets(1)
    《openbooksheet.Unprotect》
    《》内を追加したところ
    プロシージャの呼び出し、または引数が不正です。
    とエラーが出たところです。

    キャンセル

  • 2016/06/15 17:47

    上記の部分に関しては解決しました!
    そしてマクロも無事動きました!!!!
    保護されていたのが問題だったようです。
    お力添えをいただき本当にありがとうございました!!!!

    キャンセル

  • 2016/06/15 19:07

    おお、解決ですか。
    よかったです。

    キャンセル

+1

ブレークポイントを問題のところに設定して後は1ステップずつ実行してみたらどうですか?
ブレーク時にマウスカーソルを合わせたら変数の内容などチェックできますし、ウオッチも設定できますよ。

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

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

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