VBAを使って複数のシートから抽出する方法

質問

エクセルのシート２～シート２０は患者さんに関するデータが入っています。

これらのシートは3行目に患者さんのコードが入っていて、
1行目に部屋番号、2行目に氏名、
4行目～1366行目まで処方された薬や検温の数値などのデータが入っており
一列ずつが患者さん一人分の情報になっています。

シート一つで200人～250人ほどの患者さんのデータになってます。

シート１の、D1～IV1（D3～IV3でもいいです！）に患者さんのコードを入れたら、
患者さんコードが一致するシート２～シート２０の患者さんのデータを
シート１に自動で持ってくるようにする事は可能でしょうか？

患者さんのコードは重複していません。

どうかお知恵をお貸しください

回答No.5

mitarashi

#4です。
#3さんの正統的な連想配列へのデータ収納に比べて、オブジェクトを収納するのは速度的にどうなんだろうと試していて気がつきましたが、#4のコードは、Sheet2～20の一列目には見出しが入っている事を前提としておりますので、ご注意下さい。
なお、実行速度は当方の試験では#3と#4でほぼ同等でした。

回答No.4

mitarashi

いつの間にか盛り上がっていますね。
「シート１の、D1～IV1（D3～IV3でもいいです！）に患者さんのコードを入れたら」
が値を一個入れたら、イベントで動作させるという意味なのか、まとめて処理なのかわかりにくいです。これだけの広範囲で、イベントを動作させたいという状況も分かりませんし。
まとめて処理なら連想配列が速いかと思って試してみていましたが、No.3さんが先にやっていますね。
連想配列に収納するものが少々違うので投稿させていただきます。
簡便のため、「D3～IV3でもいいです！」でやっています。
Findを用いる方法もやってみましたが、処理時間はこちらの方が1/10程度で済みました。但し、D3一個の場合は、逆転しますので、もしイベントでやりたいなら、Findの方が有利です。
ところでテストデータを作って試していたら、非常に重たい。ファイルサイズを見てみたら92Mbyteもありました。19シート、250列×1366行目まで、10文字程度の文字列を入れております。現実のデータはこれほど大きくは無いかも知れませんが、10Mを超えている様なら、Accessでやる事をお勧めします。
Sub test()
Dim buf As Variant
Dim sh As Worksheet
Dim targetRange As Range, myCell As Range, destRange As Range
Dim myDic As Object
Dim i As Long

On Error GoTo errHandle
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set myDic = CreateObject("Scripting.Dictionary")
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Sheet1" Then
Set targetRange = sh.Range("$B3:$IV3")
buf = targetRange
For i = 1 To UBound(buf, 2)
If IsEmpty(buf(1, i)) Then
Exit For
Else
myDic.Add CStr(buf(1, i)), targetRange.Cells(i)
End If
Next i
End If
Set targetRange = Nothing
Next sh
With Sheets("Sheet1")
Set destRange = .Range("D3:IV3")
For i = 1 To destRange.Cells.Count
Set myCell = destRange.Cells(i)
If myDic.exists(myCell.Value) Then
myDic.Item(myCell.Value).Offset(-2, 0).Resize(1363, 1).Copy myCell.Offset(-2, 0)
End If
Next i
End With
Set myDic = Nothing
errHandle:
If Err.Number <> 0 Then MsgBox CStr(Err.Number) & ":" & Err.Description
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

お礼

mitarashiさん

ありがとうございます

皆さんにいろいろ指摘されて、質問が悪かったんだなぁって反省しています
患者さんデータがエクセルに入ってるのは、実習先の病院のシステム？なんです
職員にはきちんとした端末があって、そちらは使い勝手も良いらしいのですが、
学生は触ってはダメで、代わりにその端末から取り出したデータがエクセルに落としてあって
それを使用してるのですが、コード順にも名前順にもなっておらず、
一人の患者さんのデータを探すのに、30分かかる事もあるんです＞＜

皆さんがいろいろ考えてくれたプログラムを使って、がんばります！
ありがとうございました

回答No.3

jcctaira

chika19910402さん
こんにちは。

ややテクニック（連想配列）を使っていますが、処理はすっきりしています？
【条件】
　・患者さんのコードは重複がないこと
　・シートは物理的な番号を使用しています。
　・１シート目の３行目に検索したい患者さんのコードを設定してください。　
　・該当患者さんがいれば１列コピーします。

お試しください。

Sub 抽出()
　Dim 患者コード配列 As Object　　　　　' 連想配列
　Dim シートNO　　　 As Long
　Dim 列番号　　　　 As Long
　Dim 列番号_複写　　As Long
　Application.ScreenUpdating = False
　Set 患者コード配列 = CreateObject("Scripting.Dictionary")
　' 2～20シート 患者コード配列設定
　For シートNO = 2 To 20
　　Sheets(シートNO).Select
　　For 列番号 = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
　　　患者コード配列.Add CStr(Cells(3, 列番号)), シートNO & ":" & 列番号
　　Next 列番号
　Next シートNO
　Sheets(1).Select
　' 検索して、あれば列を複写
　For 列番号 = 4 To Cells(3, Columns.Count).End(xlToLeft).Column
　　If 患者コード配列.Exists(CStr(Cells(3, 列番号))) Then
　　　シートNO = Split(患者コード配列(CStr(Cells(3, 列番号))), ":")(0)
　　　列番号_複写 = Split(患者コード配列(CStr(Cells(3, 列番号))), ":")(1)
　　　Sheets(シートNO).Columns(列番号_複写).Copy Destination:=Columns(列番号)
　　 End If
　Next 列番号
　Application.ScreenUpdating = True
End Sub

お礼

jcctairaさん

ありがとうございます！

皆さんに教えていただいた方法をがんばって使いこなします！
明後日実習があるので、早くに行って試してみますね

ありがとうございました

回答No.2

noname#144013

こんにちは。

ご要望の処理を行うには、#1さんが書かれているようにFindメソッド等
を使用し、ループ処理にて各シート単位に「患者コード」の検索を行い、
検索できた場合に、データ転記を行うようにすれば可能だと思います。

当方で適当にシートを作成し上記の方法で検証した際のサンプルマクロ
を下記に掲載致します。
宜しければ検証してみて下さい。
※当方は、Excecl2000で検証を行いました。

■サンプルマクロ
※下記マクロは『シート１』のシートのコードモジュールに実装（貼り付け）
　　して下さい。
　注）「標準モジュール」は使用しません。

※下記マクロを検証する場合は、ご使用のExcelブックの各シートの
　レイアウトに合わせて、適せんシート名、セル位置の設定値など
　を変更して下さい。

＝＝＝↓ここから＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'== シート１：セルデータ変更時のイベント処理 ==
Private Sub Worksheet_Change(ByVal Target As Range)

　　Dim sht As Worksheet　　'シート取得用
　　Dim rngTbl As Range　　 'データ転送元のセル取得用
　　Dim rngTmp As Range　　 'セル取得用（汎用）
　　Dim nClmSta As Long　　 '列位置（開始）
　　Dim nClmEnd As Long　　 '列位置（終了）
　　Dim nClmNum As Long　　 '列数
　　Dim nRowPos As Long　　 '行位置（汎用）
　　Dim nRowSta As Long　　 '行位置（開始）
　　Dim nRowEnd As Long　　 '行位置（終了）
　　Dim nRowNum As Long　　 '行数

　　'変更セルが複数なら処理終了
　　If Target.Count <> 1 Then Exit Sub

　　'シート１の[患者コード]のセル範囲の位置・列数などを設定
　　nRowPos = 1　　　　　　　　　　 '行位置
　　nClmSta = 4　　　　　　　　　　 '開始列
　　nClmEnd = Columns.Count　　　　 '終了列
　　nClmNum = nClmEnd - nClmSta + 1 '列数

　　'転記データのデータ数(行数)を設定
　　nRowNum = 1366

　　'変更セルが[患者コード]のセル範囲内にあるか判定
　　If Application.Intersect(Target, _
　　　　Cells(nRowPos, nClmSta).Resize(1, nClmNum)) Is Nothing Then
　　　　'範囲外のセルなら処理終了
　　　　Exit Sub
　　End If

　　'データ転記先のセル範囲をクリアする
　　Target.Offset(1, 0).Resize(nRowNum - 1, 1).ClearContents

　　'入力されたセル(患者コード)を選択状態にする
　　Target.Select

　　'入力された[患者コード]が空なら処理終了
　　If Trim(Target.Text) = "" Then Exit Sub

　　'入力された[患者コード]が既に他の列で入力済みか検索
　　For Each rngTmp In Cells(nRowPos, nClmSta).Resize(1, nClmNum)
　　　　If rngTmp.Address <> Target.Address And rngTmp.Text = Target.Text Then
　　　　　　Exit For
　　　　End If
　　Next

　　'上記の検索判定で[患者コード]が既に入力済みなら処理終了
　　If Not rngTmp Is Nothing Then
　　　　'メッセージを表示して終了
　　　　MsgBox "この[患者コード]は既に他の列[ " & _
　　　　　　rngTmp.Address(False, False) & " ]で入力済みです。", _
　　　　　　vbOKOnly Or vbExclamation
　　　　Exit Sub
　　End If

　　'画面更新の無効化（※処理時間軽減の対策）
　　Application.ScreenUpdating = False

　　'データ転記元のセル取得用オブジェクトを空としておく
　　Set rngTbl = Nothing

　　'== ループ処理：他のシートから[患者コード]を検索 ==
　　'※ワークブック上の全シートの数だけループ
　　For Each sht In Worksheets

　　　　'対象シートが登録データのシートか判定する
　　　　'※シート名が『"シート" + 数字(1～2桁)』かどうかを判定
　　　　If sht.Name <> Me.Name And _
　　　　　　(sht.Name Like "シート#" Or sht.Name Like "シート##") Then

　　　　　　'検索元の[患者コード]のセル範囲の位置・列数を設定
　　　　　　nRowPos = 3　　　　　　　　　　 '行位置
　　　　　　nClmSta = 2　　　　　　　　　　 '開始列
　　　　　　nClmEnd = sht.Columns.Count　　 '終了列
　　　　　　nClmNum = nClmEnd - nClmSta + 1 '列数

　　　　　　'検索元の[患者コード]に入力された[患者コード]があるか検索する
　　　　　　Set rngTbl = sht.Cells(nRowPos, nClmSta).Resize(1, nClmNum).Find( _
　　　　　　　　What:=Target.Text, LookIn:=xlValues, LookAt:=xlWhole)

　　　　　　'[患者コード]が一致するセルが見つかったらループを抜ける
　　　　　　If Not rngTbl Is Nothing Then
　　　　　　　　Exit For
　　　　　　End If

　　　　End If
　　Next

　　'== データ転記処理 ==
　　'※データ転記元のセルが取得できていればデータ転記
　　If Not rngTbl Is Nothing Then
　　　　'[部屋番号]の転記
　　　　Target.Offset(1, 0).Value = rngTbl.Offset(-2, 0).Value
　　　　'[氏名]の転記
　　　　Target.Offset(2, 0).Value = rngTbl.Offset(-1, 0).Value
　　　　'その他のデータの転記
　　　　Target.Offset(3, 0).Resize(nRowNum - 3, 1).Value _
　　　　　　= rngTbl.Offset(1, 0).Resize(nRowNum - 3, 1).Value
　　End If

　　'画面更新の無効化を解除
　　Application.ScreenUpdating = True

　　'[患者コード]が検索できなかった時はメッセージを表示
　　If rngTbl Is Nothing Then
　　　　MsgBox "この[患者コード]の登録データはありません。", _
　　　　　　vbOKOnly Or vbExclamation
　　End If

End Sub
＝＝＝↑ここまで＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

■サンプルマクロの補足
１）シートの構成は以下を想定しています。
　　『シート１』
　　　・患者コードを入力してデータを転記するシート
　　『シート２』 ～ 『シート２０』
　　　・転記元の患者データが登録してあるシート

２）『シート１』の１行目（４列目～最終列まで）のセルの何れかに
　　「患者コード」を入力すると、Changeイベントの発生により上記
　　のマクロが実行され、「患者コード」の検索及びデータ転記が
　　行われます。

３）「患者コード」の検索は、『シート２』～『シート２０』の各シートを
　　順番に見ていき、各シートの３行目（２列目～最終列まで）の
　　セル範囲に一致するものがあるかを検索します。

４）上記３）で「患者コード」が一致するセルがあった場合に、その
　　列の１行目～１３６６行目までのデータ（患者コードは除く）を、
　　『シート１』の該当列に転記します。

添付画像は、当方で検証した際のExcelブックのシート画面です。
※見辛かったらすみません。

マクロの実装手順等については、下記の参考サイトをご覧下さい。

■参考サイト
Excelでお仕事！「VBA基本」
http://www.asahi-net.or.jp/~ef2o-inue/menu/menu04.html
Excel VBA 入門講座
http://excelvba.pc-users.net/
Excel(エクセル)VBA入門
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/index.html

以上です。

お礼

FarEyesさん

もう本当にありがとうございます！

ご想像の通り、VBAの知識は全然ないので、
判りやすく画像添付や参考サイトまで教えてもらって大助かりです！

使う時の手順もわかり易く書いてもらって感激です

本当に本当にありがとうございます

回答No.1

imogasi

>シートは3行目に患者さんのコードが入っていて、と書いていて
＞1行目に部屋番号、2行目に氏名、ということは、３行目に患者コードが入っているのか。回りくどい表現だ。
氏名でやるか患者コードを（検索でどちらを統一的に）使うかは、質問者（と回りの利用者）が決めること。
併用（名前から患者コードを割り出し）も前提にすることもよくある。
ーーー
＞可能でしょうか
可能でしょう。でも質問者がＶＢＡのコードを書けないなら、できるといっても意味が無いでしょう。
しかしこの辺になると、こんな質問コーナーで、ちょこっとヒントを回答するというわけに行く課題ではないのはわかるよね。
（１）エクセルではシートが別になる（多シートに（他の患者のデータにしろ）、散らばっているとやりにくい。
（２）２０ぐらいのシートを探していると、すらすら感がなくなるのではと思う。
（３）まだアクセスなどの方で、全患者データを患者別に単一に持つほうが良いし、検索もそれに相応しい道具・仕組みがある。
（４）本件は、プロの任せるべき課題だと思う。発展性（今後付け加えるべき機能）も潜在的にある業務と思う。（次々要求が出てきそうな、それで生半可に手をつけると質問者が後々困るのではないかと思うということ）。
VBAが動いて、結果を表示するということのほかに、機密保持やバックアップ、権限、引継ぎ、メンテナンスの連続性など必要なことが沢山在る。プロがやる仕事。
（５）データ項目数も１患者分でも、多そうで、したがって表示も複雑になりそう。
ーー
＞シート１の、D1～IV1（D3～IV3でもいいです！）
患者コードの桁数指定分の１セルで良いと思うが、なぜ２５５列なのか。
検索で、患者コード＋見たい項目１＋見たい項目２＋・・のようなのを考えているなら、なおさら複雑化する。
患者コードで全項目表示をとりあえず目指すことだろう。
ーー
エクセルＶＢＡでは１シートのセル範囲に対し、検索するＦｉｎｄメソッドが在る。これ以外は無いと思う。
質問の件に未練があるなら、それを勉強して、すべての各シートを１つずつ探すとか、患者コード（範囲など）でシートが特定されるなら、そのデータでシートを絞って、その１シートで検索するプロトタイプを作ってみるとか。
しかし質問文の表現から、質問者はVBAの経験がある臭いがしないな。
先生や職員が自作のようなシステムを使っているのを見かける医療機関などありますかな。