エクセルでBookを開かずにセルを参照する（再）

質問

昨日同じ内容で質問させていただいたのですが、添付図を付けることに思い至らずお手数をおかけしたので出直し質問です。

添付の図で製品毎の送付先連絡票という定型の帳票があり、毎日フォルダに追加されます。

この複数の帳票のフルパスを下の図の「送付先リスト」のB列にC&Pしたら、その製品のC列から行方向に帳票のシートのセル内容を参照するようにしたいのです。
このリストは新しいファイル（フルパス）が下にどんどん追加されます。

帳票（参照元）は同じ名前のシート1枚で、セルはA3、B5・・・と決まったセルです。

これが出来れば種々の定型帳票のリスト化に非常に有用なので宜しくお願いします。

開いたファイルのセル参照はINDIRECT関数で何とか出来ていますが10枚のBookを開いて、リストにフォルダのフルパスをC&Pして￥で区切り位置を使用して・・・でソロソロ限界ですので何卒HELPお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.11

HohoPapa · ベストアンサー

以下が、シートモジュールに配置するコード

'このコードは、値を取得するシートモジュールに配置
Private Sub Worksheet_Change(ByVal Target As Range)

　Dim tgCell As Range
　Dim ColCnt As Long

　For Each tgCell In Target
　　If ((tgCell.Column = SCol - 1) And (tgCell.Row >= SRow)) Then
　　　ColCnt = SCol
　　　Do
　　　　If Cells(SRow - 1, ColCnt).Value = "" Then Exit Do
　　　　Cells(tgCell.Row, ColCnt).Value = _
　　　　GetWsDate(Cells(tgCell.Row, SCol - 1).Value, _
　　　　　 ShName, Cells(SRow - 1, ColCnt).Value)
　　　　ColCnt = ColCnt + 1
　　　Loop
　　End If
　Next tgCell

End Sub

お礼

今回も何度も長コードをご回答いただき本当に感謝です!

繰り返しになりますがこれは、本当にVBAだと思いますので、有効に活用させていただきます。

最後に重ね重ねありがとうございました。

補足

このVBAは本当に種々のデータ集計に展開できると思い始めワクワクで、早出して朝一で動作確認してみました。

結果、昨夜の動作（期待通り）を再現しました。
おまけに取説付きなので変更箇所が分かり易いのでマニュアル化し易いのも助かります。

更に想定エラー対応も贅を尽くした作りになっているのも感激です!!

尚、最初の補足質問でC３セルの
＞=IFERROR(IF(B3<>"",GetWsDate($B3,"Sheet1",C$2),""),"")

＞「意味は理解できます」と言ってしまいましたが、
意味は分かるが「意図」が理解できていなかったことを恥ずかしく思います。

回答No.10

HohoPapa

>毎回B列の上から再度取得するので、
>100個位パスを埋めてみたらかなり時間がかかります。

今更ですが、これらが想定されたので、
https://okwave.jp/qa/q9797142.html　で
=GetWsDate(C3,D3,E3)　といった関数をセルに埋める解を紹介したんです。

今までのやり取りから、
この関数を埋める手法ではなく
必要な時にマクロを自前で実行する手法の方のほうが
マッチしているものと思いますので、
後者の延長でコードを書いてみました。

後記のマクロたちを、一部はシートモジュールに
一部は標準モジュールに配置します。

使い方は以下です。

DataGetAllマクロを実行すると、
Ｂ列の先頭行から最終行までデータの取得作業が行われます。

DataGetNewマクロを実行すると
取得結果の埋まっていないセルたちだけに絞って
取得作業が行われます。
対象が絞られるので、短時間で済むはずです。

また、Ｂ列が書き換わると
シートモジュールに配置したコードが実行され
書き換わった行だけを対象に取得作業が行われます。

以下注意点です。
このマクロ実行が実行された後で、
参照先ブック
（C:\Users\papa\Desktop\新しいフォルダー\製品B.xlsxといったブック）
を誰かが書き換え、その後、このマクロブックを起動した場合
最新の情報は取得されません。そのような場合は、
・DataGetAllマクロを実行する
・古い値の埋まったセルを空にして
　　DataGetNewマクロを実行
・Ｂ列の該当行のフルパスを書き換える
この何れかの処理が必要です。

以下、今度のコードで追加した考慮
・取得できない場合は、エラーメッセージをセルに書き込む
・参照しようとしたブックを別な方が開いているときを考慮

以下が、標準モジュールに配置するコード

Public Const ShName = "Sheet1"　　 '取得するシート名
Public Const SRow = 4　 'データの開始行番号
Public Const SCol = 3　 'データの開始列番号

Sub DataGetNew()
　DataGet "New"
End Sub

Sub DataGetAll()
　DataGet "All"
End Sub

Sub DataGet(SW As String)

　Dim RowCnt As Long
　Dim ColCnt As Long

　RowCnt = SRow
　With ThisWorkbook.ActiveSheet

　　If .Cells(SRow, SCol - 1).Value = "" Then
　　　MsgBox "フルパスの指定がありません"
　　　Exit Sub
　　End If
　　If .Cells(SRow - 1, SCol).Value = "" Then
　　　MsgBox "参照先セルのアドレス指定がありません。"
　　　Exit Sub
　　End If

　　Do
　　　If .Cells(RowCnt, SCol - 1).Value = "" Then Exit Do
　　　ColCnt = SCol
　　　Do
　　　　If .Cells(SRow - 1, ColCnt).Value = "" Then Exit Do
　　　　If SW = "New" Then
　　　　　If .Cells(RowCnt, ColCnt).Value = "" Then
　　　　　　.Cells(RowCnt, ColCnt).Value = _
　　　　　　　 GetWsDate(.Cells(RowCnt, SCol - 1).Value, _
　　　　　　　 ShName, .Cells(SRow - 1, ColCnt).Value)
　　　　　End If
　　　　Else
　　　　　.Cells(RowCnt, ColCnt).Value = _
　　　　　　 GetWsDate(.Cells(RowCnt, SCol - 1).Value, _
　　　　　　 ShName, .Cells(SRow - 1, ColCnt).Value)
　　　　End If
　　　　ColCnt = ColCnt + 1
　　　Loop
　　　RowCnt = RowCnt + 1
　　Loop
　End With

End Sub

'//---------------------------------------------------------
'//　データ取得関数
'//---------------------------------------------------------
Function GetWsDate(MyPath As String, _
　　ShName As String, _
　　MyAddress As String) As Variant

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object

　On Error GoTo myError

　If MyPath = "" Then
　　GetWsDate = ""
　　Exit Function
　End If
　If FileExists(MyPath) = False Then
　　GetWsDate = "Error:ブックが見つからない"
　　Exit Function
　End If

　If isBookOpen(MyPath) = True Then
　　GetWsDate = "Error:ブックが既に開いている"
　　Exit Function
　End If

　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
　cn.Open MyPath

　SQL = ""
　SQL = SQL & "select F1" & vbCrLf
　SQL = SQL & "FROM [" & ShName & "$" & MyAddress & ":" & MyAddress & "]" & vbCrLf
　rs.Open SQL, cn
　GetWsDate = rs("F1")

　rs.Close
　cn.Close
　Set rs = Nothing
　Set cn = Nothing
　Exit Function
myError:
　GetWsDate = "Error:シート、またはセルが見つからない"

End Function

'//---------------------------------------------------------
'//　ファイル有無判定関数
'//---------------------------------------------------------
Function FileExists(ChkFile As String) As Boolean
　FileExists = True
　On Error GoTo ErrorHandler ' エラー処理ルーチンを定義
　FileDateTime (ChkFile)
　On Error GoTo 0　　　　　　' エラーのトラップを無効にします。
　Exit Function　　　　　　　' エラー処理ルーチンが実行されないように Sub を終了
ErrorHandler:　　　　　　　　' エラー処理ルーチン
　FileExists = False
　Resume Next
End Function

'//---------------------------------------------------------
'//　ファイルがすでに開いていないかを判定する関数
'//---------------------------------------------------------
Function isBookOpen(ChkFile As String) As Boolean
　On Error Resume Next
　Open ChkFile For Append As #1
　Close #1
　If Err.Number > 0 Then
　　isBookOpen = True
　Else
　　isBookOpen = False
　End If
End Function

お礼

今本チャンのシートで少し修正して一覧表が出来上がったところです。
参照セルは17個（列）あり、これをコード中に挿入ではなくセルヘの直接書き込みなので非常に助かります。

改めてご回答を見てみたら、お礼の枠が空いていることに気付きました。
他のお礼枠にしたかもしれませんが改めてお礼申し上げます。

完璧です!

補足

こんばんわ！
帰宅早々試してみました。

今朝は、最初のご回答から順を追って確認しようとして失敗しましたので、今度は最新版を試してみました。

いや、イヤ、いや、イヤ・・・完璧！！！！！

今朝の投稿の後、最初のご回答で、処置シートとリストシートを分けて、処理シートの結果の行を選択しリストシートの最下行に追加転記することで十分使用に耐えると考え始めていました。（マクロボタンを2回クリックするだけ）

目的シートの最下行への転記マクロは「マクロの記録」の手直しで汎用に使用しているので、「これで行ける！」と思っていたところです。

とにかく、100%（以上）思っていた通りの動作です。

月曜日に実際のシートで動作確認してから改めて御礼させていただきます。

回答No.9

HohoPapa

前回のコードは、取得した結果を格納するシートが、
そのブックの1枚目にある前提だったので、
これを、選択中のシートに変更してみましたので
試してみてください。

Function GetWsDate...
↑の行以下は修正する必要はありません。

添付した画像を例にすると
　Const SRow = 4 'データの開始行番号
　Const SCol = 3 'データの開始列番号
という指定になります。

Sub DataGet()

　Const ShName = "Sheet1"　'取得するシート名
　Const SRow = 4 'データの開始行番号
　Const SCol = 3 'データの開始列番号
　Dim RowCnt As Long
　Dim ColCnt As Long

　RowCnt = SRow
　With ThisWorkbook.ActiveSheet
　　Do
　　　If .Cells(RowCnt, SCol - 1).Value = "" Then Exit Do
　　　ColCnt = SCol
　　　Do
　　　　If .Cells(SRow - 1, ColCnt).Value = "" Then Exit Do
　　　　.Cells(RowCnt, ColCnt).Value = _
　　　　　 GetWsDate(.Cells(RowCnt, SCol - 1).Value, _
　　　　　 ShName, .Cells(SRow - 1, ColCnt).Value)
　　　　ColCnt = ColCnt + 1
　　　Loop
　　　RowCnt = RowCnt + 1
　　Loop
　End With

End Sub

Function GetWsDate(MyPath As String, _
　　ShName As String, _
　　MyAddress As String) As Variant

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
　cn.Open MyPath

　SQL = ""
　SQL = SQL & "select F1" & vbCrLf
　SQL = SQL & "FROM [" & ShName & "$" & MyAddress & ":" & MyAddress & "]" & vbCrLf
　rs.Open SQL, cn
　GetWsDate = rs("F1")

　rs.Close
　cn.Close
　Set rs = Nothing
　Set cn = Nothing

End Function

補足

おはようございます。
つい先ほどセルの指定方法に気づいて最初のご回答に補足で返事したのですが間に合わなかったようで申し訳ありません。
あれから少しダミーシートで確認していて気付いたのですが、毎回B列の上から再度取得するので、100個位パスを埋めてみたらかなり時間がかかります。
また、Bookの保存も遅くなるようです。（あわててこれを書き始めたので再現性未確認）

保存時の時間はあまり気になりませんが動作に関しては直ぐの対象事案がすでに200-300個はあるので少し問題かもです。（実シートでの確認は月曜になります）

追加の行（パス）だけを対象に動かすようなことは無理でしょうか？

あまりコードが大きくなるようなら、毎回作業用（別）のVBAシートで実行して、結果を予め開いておいたリストシートに行のコピペ、これもできればVBA、難しければ手作業で対応することは全く問題ないので、すでに目的の80％は完成していますが、今回の動作があまりにすごいのつい贅沢な要求です。

眠気が吹っ飛びました。

回答No.8

kkkkkm

> パスを一応確認したのですが社内のPC Noには気付きませんでした。

それよりも、エクセルのメニューの「何をしますか」の上を見てください。◯松 ◯◯って…。

お礼

本当にありがとうございました！！！！
以後気を付けます！

回答No.7

HohoPapa

HohoPapaです。　補足します。

添付画像の例であれば、
（先に示したコードが配置されていれば）
C3セルに
=IFERROR(IF(B3<>"",GetWsDate($B3,"Sheet1",C$2),""),"")
という計算式を埋め、
これを必要数、下方向、右方向に複写します。
（今後増えるだろう範囲にまで複写しておきます。）
そうすれば、フルパスをB列に埋めるだけで、結果を得られます。

むろん、B列にフルパスを埋めてから
新たに得たいセルに計算式を複写する
という順番でもＯＫです。

回答No.6

masnoske

B列に送付先リストをコピペしたタイミングで参照したいということなので，以下の方法でやってみました．
参照するだけなのでブックを開く必要はありません．
ただし，参照元のファイルを削除したり移動させた場合にはマクロブックを開いたときにエラーが起きます．
逆に参照元のデータを更新した場合はマクロブックも開いた時に更新されます．
これで不都合がある場合は，参照設定したセルを値にして貼り付けるように変更してください．

マクロはマクロブックの Sheet1に記述してください．

Private Sub Worksheet_Change(ByVal Target As Range)
' 注文票ファイルの保存パスを定数に設定 (xxxの部分は自分で設定してください)
Const MY_PATH = "C:\Users\xxx\Documents\新しいフォルダー"

' 使用する変数の宣言
Dim strPath As String
Dim strAddress As String
Dim strFileName As String
Dim rngLoop As Range
Dim rng As Range

For Each rngLoop In Target
If rngLoop.Column = 2 Then
' B列のセル値が変更された場合
If rngLoop.Value = "" Then
' B列のセル値が削除された場合
rngLoop.EntireRow.ClearContents
ElseIf InStr(LCase(rngLoop.Value), LCase(MY_PATH)) <> 1 Then
' B列に無効なデータが入力された場合
rngLoop.EntireRow.ClearContents
Else
' B列に有効なデータが入力された場合
strPath = rngLoop.Value
strFileName = Mid(strPath, InStrRev(strPath, "\") + 1)
Set rng = rngLoop.Offset(0, 1)

Do
strAddress = Cells(2, rng.Column).Value
strAddress = Left(strAddress, InStr(strAddress, "（") - 1)
rng.Value = "='" & MY_PATH & "\[" & strFileName & "]Sheet1'!" & strAddress
Set rng = rng.Offset(0, 1)
Loop Until Cells(2, rng.Column).Value = ""
End If
End If
Next
End Sub

お礼

ご回答ありがとうございました。
質問内容に不備があり、数百（以上）のパスの下に新規に入力して毎回B列の全パスで実行することに無理があることに気づきませんでした。

お手数をおかけしてしまい申し訳ありませんでした。

回答No.5

HohoPapa

前回の質問に私が答えたコードを流用し紹介します。

以下のコードたちを標準モジュールに配置し
DataGetマクロを実行しみてください。

Sub DataGet()

　Const ShName = "Sheet1"　'取得するシート名
　Const SRow = 3 'データの開始行番号
　Const SCol = 3 'データの開始列番号
　Dim RowCnt As Long
　Dim ColCnt As Long

　RowCnt = SRow
　With ThisWorkbook.Sheets(1)
　　Do
　　　If .Cells(RowCnt, SCol - 1).Value = "" Then Exit Do
　　　ColCnt = SCol
　　　Do
　　　　If .Cells(SRow - 1, ColCnt).Value = "" Then Exit Do
　　　　.Cells(RowCnt, ColCnt).Value = _
　　　　　 GetWsDate(.Cells(RowCnt, SCol - 1).Value, _
　　　　　 ShName, .Cells(SRow - 1, ColCnt).Value)
　　　　ColCnt = ColCnt + 1
　　　Loop
　　　RowCnt = RowCnt + 1
　　Loop
　End With

End Sub

'別ブックからセル値を取得する関数
　'第一引数：フルパス
　'第二引数：シート名
　'第三引数：セル番地　例えば、A3とかD6
Function GetWsDate(MyPath As String, _
　　ShName As String, _
　　MyAddress As String) As Variant

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
　cn.Open MyPath

　SQL = ""
　SQL = SQL & "select F1" & vbCrLf
　SQL = SQL & "FROM [" & ShName & "$" & MyAddress & ":" & MyAddress & "]" & vbCrLf
　rs.Open SQL, cn
　GetWsDate = rs("F1")

　rs.Close
　cn.Close
　Set rs = Nothing
　Set cn = Nothing

End Function

お礼

おはようございます。

これはすごすぎます！！！！
今　朝一でご回答を期待して何度も確認していて、セル指定がないのはどうもおかしいと思いながら、ふとセル指定はリストのシートの2行目では？と思いつき飛び起きて確認したらしら～と結果が出ました。

これはすごい！！！！感動で眠気が覚めました。
念のため会社の実際のシートで確認後改めて結果報告いたします。

追記のご回答の意味が分かります。
先ずはおろかな補足へのご返信前に報告のみ。

補足

毎度お世話になります。
まだ動かないのですが、ご回答のコードが当方の期待の動きに一番近いように思われるので、本当～に基本的なことを教えていただきたく。

コードを標準モジュールにコピペし実行してみました。
＞Const ShName = "Sheet1"　'取得するシート名
のSheet1に参照元（帳票）のシート名を入れた段階で先ず実行してみたのですが、なにも怒らず、エラー表示もなく。
で、よく考えたらセルを指定してなくて・・・

＞'第一引数：フルパス
＞'第二引数：シート名
＞'第三引数：セル番地　例えば、A3とかD6

これらの引数はどこで指定するのでしょう？？？

●＞例えば、A3とかD6・・・・
（3,1）とか（6,４）でコード中のどこかに記載するのだと思うのですが、試行錯誤では当たらず。

●フルパスはリスト（結果）シートのB列に貼り付けただけで良いのでしょうか？

●シート名はコードの１行目に入れただけでよいでのでしょうか？

＞Const SRow = 3 'データの開始行番号
＞Const SCol = 3 'データの開始列番号

この数字を変えれば結果表記の開始場所が任意に決められるようなですが、フルパスはこの行列の-1（2,2）の場所から順次下に張り付けていけば良いのでしょうか？

ご回答の添付図を見てこのような結果が得られると本当に助かりますので、何卒よろしくお願いします。
既に展開する対象帳票がいくつも思いついていますので。

回答No.4

kkkkkm

前回紹介した
ブックを開かないでセルのデータを読む
http://officetanaka.net/excel/vba/tips/tips28.htm

をもとに、とりあえず一個だけですが
B3で指定されているブックから転記するコードです。

Sub Test()
Dim OpenFileName As String, SheetName As String, Target As String, buf As String
Dim i As Long
''対象ブックを選択します
OpenFileName = Sheets("Sheet1").Range("B3").Value
''ファイル名に[]を付ける
OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]")
''対象ワークシート名を取得
SheetName = "Sheet1" '参照元のシート名
Target = "'" & OpenFileName & SheetName & "'!"
''ワークシート名が正しいかどうか(存在の有無)、まず読み込んでみる
On Error Resume Next
buf = ExecuteExcel4Macro(Target & "R1C1")
If Err <> 0 Then
MsgBox "ワークシート [ " & SheetName & " ] を読めませんでした。", vbExclamation
Exit Sub
End If
On Error GoTo 0
buf = ExecuteExcel4Macro(Target & "R3C1")
''【アクティブシートに出力する】
ActiveSheet.Cells(3, "C") = buf
buf = ExecuteExcel4Macro(Target & "R5C2")
''【アクティブシートに出力する】
ActiveSheet.Cells(3, "D") = buf
buf = ExecuteExcel4Macro(Target & "R6C3")
''【アクティブシートに出力する】
ActiveSheet.Cells(3, "E") = buf
End Sub

お礼

ご回答ありがとうございます。

動作確認し、1行目のパスで指定したコード中のA3,B5,C6のセル内容をB列以降の列に参照することを確認しました。
おそらく後はこれを繰り返すと期待通りになることが確認されたと思います。

ただし今回はNo11さんのご回答で解決できました。
何度もお手数をおかけしました。

回答No.3

kkkkkm

> このリストは新しいファイル（フルパス）が下にどんどん追加されます。

「10枚のBookを開いて」という事は毎回確実に10個のブックのフルパスが追加されるのでしょうか。
転記をしたいブックのフルパスをC&Pした一番最初のセルを選択してボタンを押したら、そこから始めて10個分下に転記をする。
のでしょうか。手順の詳細を箇条書きで記載してください。ご自身でご自身の環境に合わせてコードを手直しできるのでしょうか。

お礼

前回の質問から継続してお手数をおかけしてしまいました。
質問以外でもお手数をおかけし申し訳ありません。

色々条件が抜けておりかなりのストレスを感じさせていること申し訳なく。
質問ができないということはコードの手直しもできないわけで本当に申し訳なく。

毎回反省してもレベルが上がらないのは寄る年波のせいだとご容赦ください。

今後ともよろしくお願いいたします。

回答No.2

kkkkkm

添付画像に個人名があります、削除依頼しています。

お礼

ありがとうございます。何から何までおせわになります。

フルパスがサーバだとまずいと思いデスクトップにフォルダを作って、パスを一応確認したのですが社内のPC Noには気付きませんでした。

ご回答以外までお手数をおかけしてしまいました。

回答No.1

masnoske

とりあえず送付先連絡票を開いて、1件分のデータを送付先リストに転記するマクロを作ってみてください。
あとは、それをFor Each Nextで回すだけなので。
ブックを開かずに処理するのは、その後に修正すれば良いです。

お礼

早々のご回答ありがとうございます。
ご指摘の内容は理解できるのですが、残念ながらマクロの記録を参考に編集する程度のレベルにつき１から作るこちは出来ないのが悲しい現実です。