検索結果を表示させるには？？発展させて

質問

http://oshiete1.goo.ne.jp/qa3081314.html
これでも十分仕上がったのですが、さらに発展をさせて使用したいのです

例
sheet1で
A 　　　　 B 　　　 C　　　 D 　　　 E 　　　　 F 　　 G　　　　　　　H
1入院日 氏名 術日 術眼 術式 日帰り？ 主治医 部屋番号
26/1　　佐藤 6/2 右 ○○ 入院 高橋　201
3 　　　　　　 　 6/3　左 △△
46/2　　川端 6/2 右　 ×× 入院　　 松橋 202
5 　　　　　　　 6/3 左 ×○
※A2とA3、B2とB3、F2とF3、G2とG3、H2とH3はセルが結合している
　A4とA5、B4とB5、F4とF5、G4とG5、H4とH5はセルが結合している

このような大元がありまして

sheet2に
術日に応じて、名前・術眼・術式・日帰り等をオートフィルタではなく
関数でズラッと出せるようにしたいのですが、どうすれば良いのでしょうか
？？

A B　　　C　　　D　　E　　　　　　F　　　　G
16/3として
2名前　　術眼　術式　日帰り？？　主治医　部屋番号
3佐藤 　 左　　△△　入院　　　　高橋　201　
4川端 左 ×○ 入院　　 松橋 202

このように、Sheet1で簡素化してセルを結合して表示しても、
sheet2ではセル結合してもしっかり反映して、検索結果を表示させたいのですが、どのような関数式を用いればよろしいでしょうか？？

よろしくお願いします

回答No.3

pc_knight · ベストアンサー

#2です。
Sub Test()
Dim rw1 As Integer, rw2 As Integer, rw3 As Integer, rww As Integer
Dim clm As Integer
km = Array("名前", "術眼", "術式", "日帰り？？", "主治医", "部屋番号")
If Sheets("Sheet2").Cells(1, 1) = "" Then
ret = MsgBox("Sheet2のA1セルに月日が入っていません。" & Chr(13) & "処理を中止します。", vbOKOnly + vbExclamation, "警告")
Exit Sub
End If
Sheets("Sheet2").Range("A2:F65536").ClearContents
For clm = 1 To 6
Sheets("Sheet2").Cells(2, clm).Value = km(clm - 1)
Next clm
rw3 = 2
For rw1 = 2 To Sheets("Sheet1").Range("C65536").End(xlUp).Row
If Sheets("Sheet1").Cells(rw1, 3) = Sheets("Sheet2").Cells(1, 1) Then
For rw2 = rw1 To 2 Step -1
If Sheets("Sheet1").Cells(rw2, 1) <> "" Then
rw3 = rw3 + 1
Sheets("Sheet2").Cells(rw3, 1).Value = Sheets("Sheet1").Cells(rw2, 2)
For clm = 2 To 6
If clm <= 3 Then
rww = rw1
Else
rww = rw2
End If
Sheets("Sheet2").Cells(rw3, clm).Value = Sheets("Sheet1").Cells(rww, clm + 2)
Next clm
Exit For
End If
Next rw2
End If
Next rw1
ret = MsgBox("終了しました", vbOKOnly)
End Sub

でいかがでしょう！！

お礼

早速のお返事ありがとうございました。

やってみましたが、出来ました。すばらしいですね。
実際に使って運用してみます。ありがとうございました

今後も自分はVBA全く分からないので、勉強してみますが、何か分からないことあったら、ご教授お願いします

回答No.2

pc_knight

ご要望のようなことを行おうとすると関数では対応できないように思います。
ご要望の資料を自動的に作るようにするのは、プログラミングの世界です
ご要望の資料を瞬時に作れるものを作りました。（末尾に記載）
簡単ですから、お試しください！！。
(1)先ず、末尾に記載のＶＢＡをVisualBasicの標準モジュールに貼りつけてます。
(2)あとは、資料を作りたい都度、”Alt”キーと”F8”キーを押しマクロ”Test”を選択”実行”をクリックすれば瞬時に作成できます。
※(2)の操作の別方法として、Sheet1にボタンを配置して、これをクリツクする方法もあり、操作性の良いこれがおすすめ。(ボタンの作成法：ツール(T)を右クリツク→ボタンを選択→ボタン描画→マクロ名"Test"を登録)

☆標準モジュールへの貼り付け方
AltキーとF11キーを同時に押し挿入(I)標準モジュールを選択することでModule1が用意されます。ここに貼り付けをします。
☆ＶＢＡ
Sub Test()
Dim rw1 As Integer, rw2 As Integer, rw3 As Integer, rww As Integer
Dim clm As Integer
km = Array("名前", "術眼", "術式", "日帰り？？", "主治医", "部屋番号")
Sheets("Sheet2").Cells.ClearContents
Sheets("Sheet2").Range("A1").FormulaR1C1 = "=TODAY()+7"
For clm = 1 To 6
Sheets("Sheet2").Cells(2, clm).Value = km(clm - 1)
Next clm
rw3 = 2
For rw1 = 2 To Sheets("Sheet1").Range("C65536").End(xlUp).Row
If Sheets("Sheet1").Cells(rw1, 3) = Sheets("Sheet2").Cells(1, 1) Then
For rw2 = rw1 To 2 Step -1
If Sheets("Sheet1").Cells(rw2, 1) <> "" Then
rw3 = rw3 + 1
Sheets("Sheet2").Cells(rw3, 1).Value = Sheets("Sheet1").Cells(rw2, 2)
For clm = 2 To 6
If clm <= 3 Then
rww = rw1
Else
rww = rw2
End If
Sheets("Sheet2").Cells(rw3, clm).Value = Sheets("Sheet1").Cells(rww, clm + 2)
Next clm
Exit For
End If
Next rw2
End If
Next rw1
ret = MsgBox("終了しました", vbOKOnly)
End Sub

お礼

早速のお返事ありがとうございます

早速試してみました。感激です。簡単に瞬時にできました。

もう一つお願いがあるのですが、TODAY()+7なのですが
Sheet2のA1には入力規則のリストで、一か月分の日にちを入れてます。
入力規則で選択した日にちを入れたあと、testボタンを押したら、その日のデータが出る感じにしたいのですがどうでしょうか？？

よろしくお願いします！

回答No.1

maron--5

>Sheet1で簡素化してセルを結合して表示しても
◆例えば「B2とB3を結合する」とB2にはデータがありますが、B3にはデータがありません
◆データが無いものを検索しようとすると、大変難しくなります
◆１つのデータを一行に入力するのがデータベースの基本です
◆セルを結合せず入力されるのであれば、方法はありそうですが