こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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


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

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

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

マルチメディアファイルは削除されたか見つかりません。

投稿日時 - 2020-09-11 22:25:25

QNo.9797851

困ってます

質問者が選んだベストアンサー

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


'このコードは、値を取得するシートモジュールに配置
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

投稿日時 - 2020-09-13 15:11:39

補足

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

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

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


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

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

投稿日時 - 2020-09-14 09:02:17

お礼

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

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

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

投稿日時 - 2020-09-14 09:05:28

ANo.11

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(11)

ANo.10

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

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

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

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

使い方は以下です。

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

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

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

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

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


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

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

投稿日時 - 2020-09-13 15:08:27

補足

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

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

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

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

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

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

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

投稿日時 - 2020-09-13 21:13:51

お礼

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

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

完璧です!

投稿日時 - 2020-09-15 11:17:39

ANo.9

前回のコードは、取得した結果を格納するシートが、
そのブックの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

投稿日時 - 2020-09-13 07:19:37

補足

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

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

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

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

眠気が吹っ飛びました。

投稿日時 - 2020-09-13 07:51:56

ANo.8

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

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

投稿日時 - 2020-09-12 21:17:03

お礼

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

投稿日時 - 2020-09-12 21:31:26

ANo.7

HohoPapaです。 補足します。

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

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

投稿日時 - 2020-09-12 12:45:48

ANo.6

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

投稿日時 - 2020-09-12 12:06:39

お礼

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

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

投稿日時 - 2020-09-13 21:47:09

ANo.5

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

以下のコードたちを標準モジュールに配置し
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

投稿日時 - 2020-09-12 08:59:33

補足

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

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

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

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

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

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

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

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

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

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

投稿日時 - 2020-09-12 22:29:18

お礼

おはようございます。

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

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

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

投稿日時 - 2020-09-13 07:22:25

ANo.4

前回紹介した
ブックを開かないでセルのデータを読む
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

投稿日時 - 2020-09-12 07:41:58

お礼

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

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

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

投稿日時 - 2020-09-13 21:32:59

ANo.3

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

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

投稿日時 - 2020-09-12 07:15:07

お礼

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

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

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

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

投稿日時 - 2020-09-13 21:18:20

ANo.2

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

投稿日時 - 2020-09-12 06:52:07

お礼

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

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

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

投稿日時 - 2020-09-12 21:05:42

ANo.1

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

投稿日時 - 2020-09-12 06:10:50

お礼

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

投稿日時 - 2020-09-12 21:00:53

あなたにオススメの質問