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

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

ただいまの
回答率

90.47%

  • Excel

    1967questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • VB

    345questions

    VB(ビジュアルベーシック)はマイクロソフトによってつくられたオブジェクト指向プログラミング言語のひとつで、同社のQuickBASICが拡張されたものです。VB6の進化版といわれています。

  • マクロ

    291questions

    定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

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

解決済

回答 3

投稿 編集

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

teryyyyy2

score 11

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

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

ソースがこちらです。

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/14 17:42

    コメントありがとうございます。
    どこまでデータが上書きされるのか確認するために
    1-57(A-BE)に適当な値を入れてマクロを起動すると
    1-45(A-AS)は空白に書き換わり
    46-57(AT-BE)は値が入ったままになっています。

    キャンセル

  • 2016/06/14 18:45 編集

    そこまでの動作は、処理の最初に
    ```
    ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents
    ```
    でクリアしているからだと思います。

    問題はその後に指定したフォルダ内のxlsファイルの内容が、想定された位置にコピーされるかどうかだと思います。
    空欄のままということは、何もコピーされなかったということでしょうか?

    また、ParCopy関数を先ほど提示したコードに置き換えて動作確認はされましたでしょうか?
    まだでしたら一度実行して、どんなメッセージが表示されたか教えていただきたいです。

    キャンセル

  • 2016/06/15 09:45

    質問欄に出てきたメッセージを追記しました。
    よろしくお願いします。

    キャンセル

  • 2016/06/15 09:50

    メッセージを見てわかるとおり、コピー元ファイルの「処理中」シートから各セルの値を取ろうとしていますが、全て値が入っていないようです。
    対象としているファイルやシートは意図したもの(コピーしたい内容が書かれているシート)になっていますか?

    キャンセル

  • 2016/06/15 10:03

    なっていませんでした…。隠れているシートがあり、それを指定していたようです。

    キャンセル

  • 2016/06/15 10:14 編集

    Worksheets(1)という書き方は、(非表示も含めて)左側のシートから順に連番されますので、そこが問題だったのですね。

    問題点が見つかったので、あとはどうやって目的のシートを取得できるようにするか決めるだけですね(^-^)b

    キャンセル

  • 2016/06/15 10:16

    教えていただいた通りシートを指定しなおし、実行した所、取得したいデータのシートになった事は確認できたのですが、なぜかセル内の値を取得してくれません。考えられる理由は何かありますでしょうか…?

    キャンセル

  • 2016/06/15 11:41

    >隠れていたシートがありそこを指定していた間違いを修正しました。
    >教えていただいた通りシートを指定しなおし

    「取得の仕方を決めましょう」とは書きましたが、どう変えるかまでは書いていなかったはずです。

    どのように対応されましたか?
    ・目的のシートが一番左になるよう、シートの並びを変更した
    ・目的のシートが取得できるよう、Worksheets(n)の添え字nを変更した

    >追記2の部分が未だに謎のままです。
    これについては前述したとおり、処理の最初でA3:AS3005の範囲をクリアしているからです。
    AT列以降はクリアしていませんが、一部は後の処理で取り込まれる側シートの取得値に置き換わります。
    ```
    'ボタンを押したとき
    Sub FolderSelect()
    ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents

    '↓取り込む側(シート2)のA3:AS3005をクリアしています。
    ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents

    Dim folderpass As String
    '・・・(以下略)
    ```
    その後、取り込まれる側シートの値が入ってこないというところが問題ですね。


    >取得したいデータのシートになった事は確認できたのですが、なぜかセル内の値を取得してくれません。

    メッセージボックスに表示される内容はどうなったでしょうか?
    ・シート名は目的のシート名が表示されるようになった
    ・セルの値は表示されない。
    (たとえばコピー元シートのA70には値が入っているのにメッセージボックスのA70:の横には値が表示されない)
    ということでしょうか?

    キャンセル

  • 2016/06/15 11:50

    目的のシートが一番左に来るように修正をしました。
    クリアされているという部分を理解しました!
    メッセージボックスの内容は目的のシートになりましたが、おっしゃる通り、コピー元シートのA70には値が入っているのにメッセージボックスのA70:の横には値が表示されない状態です。

    キャンセル

  • 2016/06/15 16:44 編集

    既に提示しているものが全てですが、一応全体ソースを提示しました。

    あと、試していただきたいことが2つあります。

    1つは「単純なファイルをコピー元としてデータが取得できるか?」です。
    ~手順~
    ①新規にフォルダを作成する。
    ②新規にエクセルファイルを作成する。
    ③Sheet1のA70セルに何か値をセットする。
    ④①で作成したフォルダの中に保存してエクセルを閉じる。
    ⑤今回のマクロを実行し、①で作成したフォルダを指定する。
     ⇒結果はどうなりますか?


    2つめは「コピー元のA70にセルとしてコピーできる値が入っているか?」です。
    ~確認手順~
    ①うまく取り込めないコピー元エクセルブックを、普通にエクセルから開く
    ②そのブック内の非表示のシートを全て表示する
    ③一番左のシートで、[Ctrl]+[G]キーを押し、移動ダイアログを表示する
    ④参照先の入力欄に「A70」を入力した状態で「OK」ボタンをクリックする
    ⑤A70セルにカーソルがあたるので、[Ctrl]+[C]キーを押してセル内容をコピーする
    ⑥コピーした内容をメモ帳などに張り付ける
     ⇒セルの内容は張り付きましたか? 改行のみになりませんか?


    手探りでの面倒な調査になってしまいますが、今はこれくらいしか思いつきません。。

    キャンセル

  • 2016/06/15 16:46

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

    キャンセル

  • 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/14 13:38

    取り込まれる側の1シート目の指定した部分を、
    取り込む側の2シート目に入力させたいのです。
    教えていただいたやり方では解決しませんでした…。

    キャンセル

  • 2016/06/14 14:43

    そういう仕様的なことは質問に書いておかないと、誰も回答できないですよ。

    とりあえずfor文は不要そうなので、削除しましょう。
    For i = 1 To openbook.Worksheets.Count

    あとrowで判断しているところ、
    If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> "1" Then
    ここも不要かもしれません。
    空じゃなければという判断だと思うので、必要に応じて。
    但し、<>"1"のところは >1 にしましょう。

    それから謎の処理、
    Dim blof As Variant
    ReDim blofar(0 To 1)
    For j = 0 To UBound(blof)
    blofar(j) = Trim(blof(j))
    Next j
    これは使われていないようなので削除してもよさそうです。

    キャンセル

  • 2016/06/14 15:48

    言葉足りずで本当に申し訳ありません。
    書いていただいた通り変更してみたのですがだめでした。
    仕様を追記しましたので呆れずにご助力願います…。

    キャンセル

  • 2016/06/14 17:39

    だめでした、ではわからないので、どうなったのか、どこまで行ったのか、何々はいいけど何々はダメ、などを報告してください。

    キャンセル

  • 2016/06/14 17:46

    教えていただいたとおりに変更を行うとNEXTに対してのForがありませんとエラーが出ます。
    よろしくお願いします。

    キャンセル

  • 2016/06/14 17:55

    いや、当然forを削除しているのですから、nextも消してくださいよ。
    というか、先ほどは変更してみたと書かれていたのに、実はやってなかったのでしょうか…。

    キャンセル

  • 2016/06/14 18:00

    やってみてダメだったので戻したということです…。申し訳ありせん。
    1-47(A-AU)まではすべてが空白になり、48-57(AV-BE)は指定したセルだけ空白になるという結果になりました。わからないことばかりで申し訳ありません。

    キャンセル

  • 2016/06/14 18:07

    例えばここ、
    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
    6列目に入れようとしているのが、本当にA70なのか、というのを一つずつ見るしかないですかね。
    そこが間違いないのなら、うーん、申し訳ない、わからないです。

    キャンセル

  • 2016/06/15 11:33

    お時間かけて考えていただきありがとうございます。
    多少進展がありましたのでもう少し手を貸していただけると嬉しいです…。
    よろしくお願いします。

    キャンセル

  • 2016/06/15 13:28

    追記2について原因の特定も再現もできていないのですが…。
    試しに値のコピーをしているところを、両方ともCellsを使うようにしてみてはいかがでしょうか。
    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")

    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Cells(70,1)

    キャンセル

  • 2016/06/15 15:54

    何も変わりませんでした…。何が原因か探れればいいのですが…。

    キャンセル

  • 2016/06/15 15:54

    私もコピー元シートからセルの値が取得できない理由が全く思い当たらず、同じこと(cellsに変更)を試していただこうと思っていました。

    手元に作った環境ではちゃんと取得できているので、コピー元シートの問題ではないかと思っているのですが…。

    キャンセル

  • 2016/06/15 16:06

    teryyyyy2さん>
    先ほど書いたコードしかやってないとかないですよね。
    ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
    この行以降もやってますよね。
    疑うわけではないですが…。

    キャンセル

  • 2016/06/15 16:08

    jawaさん>
    コピー元のセルを結合してみたり、数式にしてみたり、シートの保護をしてみたりと、色々やってみましたけど、とんと原因がつかめません。
    なんなんでしょうね。

    キャンセル

  • 2016/06/15 16:12

    jawaさん、お時間無い中考えていただきありがとうございます。
    よろしければjawaさんの作ったソースを一度いただいてもよろしいでしょうか?
    補足でお伺いしたいのですが、"A70"と表記しているところは正確には”A70-F70”の結合したセルなのですがもんだいはありますでしょうか?

    キャンセル

  • 2016/06/15 16:15

    >>ttypさん
    そこはその部分の全コードに対して変更を行いました。

    キャンセル

  • 2016/06/15 16:15

    ここはjawaさんのレスではないですが。
    私の環境では結合していても問題はありませんでしたよ。

    キャンセル

  • 2016/06/15 16:16

    > そこはその部分の全コードに対して変更を行いました。
    ですよね。疑ってすみませんでした。

    キャンセル

  • 2016/06/15 16:46

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

    キャンセル

  • 2016/06/15 16:53

    ということは、openbook.Close False のところを通過していないということになりますね。
    であれば、エラーが発生しているはずなので、エラーハンドラーのところを次のようにするとエラーの内容が出ると思うので、試していただけますか。
    myError:
    MsgBox err.Description ' ←追加
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"

    キャンセル

  • 2016/06/15 17:10

    エラーメッセージが出てきました!
    質問欄にSSを張り付けました。
    保護されていたのが原因ということでしょうか…

    キャンセル

  • 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で質問しよう!

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

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

  • Excel

    1967questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • VB

    345questions

    VB(ビジュアルベーシック)はマイクロソフトによってつくられたオブジェクト指向プログラミング言語のひとつで、同社のQuickBASICが拡張されたものです。VB6の進化版といわれています。

  • マクロ

    291questions

    定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。