[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『表の固定されてない列の同じ行にある値を検索する方法』（はっしー）
1つのシートに表が横並びに2つあり、それぞれが先頭列に型番、最上行に日付がついています。 仮に右から表A、表Bとします。AとBの日付は同じ日付が入ってます。型番は重複しません。 日付は数日おきに不定期に追加されます。それに伴い、表Bの範囲が日付の追加分だけ後ろへ移動します。
この場合で、別シートで検索（例えばHLOOKUPやVLOOKUPなど）した場合、検索値となる日付が重複する 問題と表Bの範囲がずれるため範囲の指定をどうすればよいか？という問題が発生します。
表Aと日付増加により移動する表Bの2つの表から日付別、型番別の検索をするためにはどの様な検索式に すればよいか教えてください。
＜ 使用 Excel：Excel2013、使用 OS：Windows8.1 ＞
表Aと表B のレイアウトを具体的な例で示されてはいかがでしょう。
表A
A1 :日付 A2 :型番1 A3 :型番2
表B
F1 :日付 F2 :型番x F3 :型番y
表Aに日付を追加すると
表A
A1 :日付 B1 :日付 A2 :型番1 B2 :型番？ A3 :型番2 B3 :型番?
このとき、表B は
G1 :日付 G2 :型番x G3 :型番y
と移動してしまう とか。 （この私の理解そのものが誤解の産物かもしれませんが）
で、そういった状況で、何で、何を検索したいのかも例として具体的に説明されてはいかがですか？
（β） 2015/03/15(日) 07:54
（移動前） 表A 表B
A B C D E ～ AT AU AV AW AX 1 3/2 3/3 3/4 3/5 3/2 3/3 3/4 3/5
2 AA101 BB105
3 AA102 CA101
4 AB101 CC101
5 BB103 CC102
（移動後） 表A 表B
A ～ E F G H ～ BC BG BH BI BJ 1 3/5 3/6 3/9 3/10 3/5 3/6 3/9 3/10
2 AA101 BB105
3 AA102 CA101
4 AB101 CC101
5 BB103 CC102
例として移動前と移動後では上記のような感じに変わります。
１行目は日付、２行目以下は型番、表AのB2～、表B（移動前）AU2～、（移動後）BG2～は各数量が入ってます。 別BOOKの表に全体をコピー貼り付けしてそこから必要な日付にある型番の数量を表示させるように貼り付けした表から HLOOKUP関数などで求めようとしましたが、表Aは型番欄固定なので問題ないのですが、表Bは不定期で日付が追加されると 型番のある列が後ろへ移動してしまい検索式が成り立たなくなってしまうため困ってます。
よい方法があればご教授ください。
また、説明の不足、不明あるやもしれません。その都度、補足します。 宜しくお願いいたします。
（はっしー） 2015/03/15(日) 12:25
案１）シートを分ける
案２）Ｂ表に名前をつける
案３）別ブックにコピーするときＡ表の下にＢ表を置く
（みけ） 2015/03/15(日) 14:46
（マナ） 2015/03/15(日) 14:53
Sub test()
Dim a as integer
a=1
Do until Cells(2,a).value=空の文字を表す記号
a=a+1
Loop
Cells(1,1).value=a-1
Cells(1,2).value=a+1
a=a+1
Do until Cells(2,a).value=空の文字を表す記号
a=a+1
Loop
Cells(1,3).value=a-1
End Sub
空の文字を表す記号と書いてあるのは、スマホではこれが表現できないからです。
一行目の一列目にA表の終わりの列の番号、２列目にB表の始まりの列の番号、３列目にB表の終わりの列の番号が記入されるマクロです。この数字をもとに検索範囲を指定すればいいのではないでしょうか？
もし、vbaを使いたくないのなら、B表を違うシートに移すか、A表の下に移すしかないと思います。
（スズメ） 2015/03/15(日) 15:31
皆様、お世話になっております。
表Aと表Bは１つのシート内にあります。これとは別に同形式（型番の違うもの）のシートが1つ、表が１つのもの が1つ、計3シートからできてます。
表は全5つあり、全て別ブックのシートにコピー貼り付けしてから必要日の数量を型番別に検索して表示させます。
元の3シートのファイルは取引先の別会社からメール添付により送られて来るもので、一切の編集はできません。
また、一連のメール添付のファイルのコピーから別ブックのファイルへの貼り付け、必要日の数量検索、出力用 シートの印刷の作業はPCに不慣れな者でも簡単に手間や時間をできるだけ掛けずにできるようなものにしなけれ ばならないため自動化（ここでいう表Bの見出し位置の検出）が必要になってます。
私自身が行うのであれば手作業でも大した手間はかかりませんが、PC不慣れ者にしてもらわなければならない 状況も当面の間は変更できそうにないことをどうかお察しください。
そのため、貼り付けシートに張り付ける作業も印刷もまた、印刷後の消去もマクロボタンをクリックすればでき るようにしてあります。（印刷後はコピーしたものは消去して、繰り返し使用します。）
元ファイルから貼り付け用シートに全コピーして、その張り付けたものを元に出力用シートに必要日を入力 すると型番別の数量が表示される仕様を考えてます。
vbaでも関数でも、両方の組み合わせでも可能であればOKです。宜しくお願いいたします。
（はっしー） 2015/03/15(日) 16:44
仕様は、まだよく読んでいませんが、移動前の状態で、１行目が A1 と AT1 のみが空白。 移動後も、A1 と BC1 のみが空白。 これら空白セルの列が型番列だと判断できます。
表Aの列は A列から、最初の空白セルの列の１つ前まで。 表Bの列は ２つめの空白セルの列から 1行目のデータ最終列まで。
これで、各表の１行目の領域が特定できます。
あとは、各表の１列目で型番を検索、各表の１行目で、日付を検索。 これらの取得情報から目的のセルを参照し数量を抜き出す。
関数でもできそうですし、もちろん、ＶＢＡでもできるでしょうね。 ＶＢＡ処理の場合もループなしでいけるはずですね。
（β） 2015/03/15(日) 17:06
β様、お世話になります。
>仕様は、まだよく読んでいませんが、移動前の状態で、１行目が A1 と AT1 のみが空白。 >移動後も、A1 と BC1 のみが空白。 >これら空白セルの列が型番列だと判断できます。
誠に申し訳ありませんが、上記（ 2015/03/15(日) 12:25）の表は略表であり、実際には空白ではなく型番に 対応する機種名が入ってます。 また、表Aと表Bの間に空欄、空列などは設けられていません。
すみません、説明不足でした。 （はっしー） 2015/03/15(日) 17:30
なるほど。
では、１行目で日付型データが現れる１つ前が各表の開始位置ということですね。 あるいは、その、「機種名」が、「数字」ではないとすれば、もっと簡単に把握できますが。 （つまり文字列だったとしたら）
ところで、検索する型番と日付は、どのように指定する予定ですか？
（β） 2015/03/15(日) 17:38
ＶＢＡです。 関数でもできると思いますので、それがよければ、関数案の回答をお待ちください。
Sheet1 の A1 に 型番、B1 に日付をいれて、以下マクロを実行。 なお、表A,表B は Sheet2 にあるという前提です。
(シート名については実際のものに直してもらってＯＫです）
標準モジュールに。
Sub Test()
Dim r As Range
Dim cols As Range
Dim listA As Range '表A
Dim listB As Range '表B
Dim er As Boolean
Dim mdl As Variant
Dim dt As Variant
Dim iA As Variant
Dim jA As Variant
Dim iB As Variant
Dim jB As Variant
With Sheets("Sheet1") '★検索用シート 実際の名前に変更。
mdl = .Range("A1").Value
dt = .Range("B1").Value2
End With
Set r = Sheets("Sheet2").Range("A1").CurrentRegion '★表A,Bがあるシート。実際の名前に変更。
On Error Resume Next
Set cols = r.Rows(1).SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If cols Is Nothing Then
er = True
ElseIf cols.Cells.Count <> 2 Then
er = True
End If
If er Then
MsgBox "1行目の日付行が規定通りになっていないので処理できません"
Exit Sub
End If
Set listA = r.Resize(, cols.Areas(2).Column - 1)
Set listB = r.Offset(, cols.Areas(2).Column - 1).Resize(, r.Columns.Count - listA.Columns.Count)
iA = Application.Match(mdl, listA.Columns(1), 0)
jA = Application.Match(dt, listA.Rows(1), 0)
If IsNumeric(iA) And IsNumeric(jA) Then
MsgBox "表A内の該当の数量は " & listA.Cells(iA, jA) & " です"
Else
MsgBox "表Aにはありません"
End If
iA = Application.Match(mdl, listB.Columns(1), 0)
jA = Application.Match(dt, listB.Rows(1), 0)
If IsNumeric(iA) And IsNumeric(jA) Then
MsgBox "表B内の該当の数量は " & listB.Cells(iA, jA) & " です"
Else
MsgBox "表Bにはありません"
End If
End Sub
（β） 2015/03/15(日) 18:13
β様、お世話になります。
>では、１行目で日付型データが現れる１つ前が各表の開始位置ということですね。 >あるいは、その、「機種名」が、「数字」ではないとすれば、もっと簡単に把握できますが。
機種名は半角英数もの、文字列で表示されており、数字のみはありません。 （例：111/222,ABC 1x,アイウ３Ｇ）
>ところで、検索する型番と日付は、どのように指定する予定ですか？
出力用シートに日付入力欄を設けてそこへ日付を入力すると入力した日付から４日分を表示します。 出力用シートの型名は固定で入力されています。その型名にあった行に左から４日分の数量を表示します。↓
（イメージ） 3/9 3/10 3/11 3/12
型名1 350 420 500 320 型名2 25 88 型名3 120 99 110
（はっしー） 2015/03/15(日) 18:43
了解
コードは↑の要件にあわせて、書き直し再アップ予定。
で、きっと、↑の要件でも、関数の先生方からは関数案もいただけると思う。
（β） 2015/03/15(日) 19:03
出力用シートですが、型名1 は A2、3/9 は B1 と考えていいですか？
（β） 2015/03/15(日) 20:12
β様、お世話になります。
出力用シートの上部に日付入力欄、コピー貼り付けボタン、印刷ボタン等を配置しています。
表はB11～I55で型番名１行目はB12、日付１列目はD11になってます。 （はっしー） 2015/03/15(日) 20:27
出力用シートのシートタブを右クリックしてコードの表示を選び、でてきたところ（シートモジュール）に以下を貼り付け。
表A,Bがあるシート名を "Sheet2" としているので、そこは実態に合わせてなおしてください。
出力用シートのD11に日付を入れるか、B12～B55の型番を変更追加すれば自動的に処理。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim mdl As Variant
Dim dt As Variant
If Intersect(Target, Range("D11")) Is Nothing And Intersect(Target, Range("B12:B55")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("D11:G11").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
With Range("D12:G55")
.ClearContents
For Each c In .Cells
mdl = c.EntireRow.Range("B1").Value
dt = c.EntireColumn.Cells(11).Value2
If mdl = "" Then Exit For
c.Value = GetVal(mdl, dt)
Next
End With
Application.EnableEvents = True
End Sub
Private Function GetVal(mdl As Variant, dt As Variant) As Variant
Dim r As Range
Dim cols As Range
Dim listA As Range '表A
Dim listB As Range '表B
Dim i As Variant
Dim j As Variant
Set r = Sheets("Sheet2").Range("A1").CurrentRegion '★表A,Bがあるシート。実際の名前に変更。
On Error Resume Next
Set cols = r.Rows(1).SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If cols Is Nothing Then Exit Function
If cols.Cells.Count <> 2 Then Exit Function
Set listA = r.Resize(, cols.Areas(2).Column - 1)
Set listB = r.Offset(, cols.Areas(2).Column - 1).Resize(, r.Columns.Count - listA.Columns.Count)
i = Application.Match(mdl, listA.Columns(1), 0)
j = Application.Match(dt, listA.Rows(1), 0)
If IsNumeric(i) And IsNumeric(j) Then
GetVal = listA.Cells(i, j)
Exit Function
End If
i = Application.Match(mdl, listB.Columns(1), 0)
j = Application.Match(dt, listB.Rows(1), 0)
If IsNumeric(i) And IsNumeric(j) Then GetVal = listA.Cells(i, j)
End Function
（β） 2015/03/15(日) 21:02
β様、お世話になっております。
上記コードを指示通りコピーして変更箇所を変更して実行してみました。 G～J列の日付以外、全て空欄になってしまいます。
（はっしー） 2015/03/15(日) 23:40
出力用シートや表A,Bのシートのレイアウトについて、こちらが誤解しているところがあるんでしょうね。
・表A,Bのシート
表Aと表B は 「連続」して配置されていると理解しています。 2015/03/15(日) 12:25 の移動後の例でいうと、B1～BA1まで、隙間なく、表A側の日付が列挙されていると考えています。 （表Aと表Bの間には、空白列もなければ、そのほかの何かもない）
たとえば、こちらで作成したテストデータは、A1:G20 が表A、H1:N20が表B。日付は3/2～3/7の小さな表にしています。
・出力用シート
2015/03/15(日) 20:27 の説明、
「表はB11～I55で型番名１行目はB12、日付１列目はD11になってます。」
ということでしたので、D11:G11が日付、D12:G55 が値を転記する対象領域にしています。
「G～J列の日付以外、全て空欄になってしまいます。」
G～J列の日付 というところがわからないのですが？
（β） 2015/03/16(月) 06:53
β様、お世話になっております。 返事遅くなりすみません。
>G～J列の日付 というところがわからないのですが？ D～G列の間違いでした。
表A,Bのシート、出力用シートのテストデータ、レイアウトについては上記を見る限り問題はないと思います。
ただ実際は表AはB～BA範囲に対してテストデータではA～G範囲（表Bに関しても同様）なのでコード内でシー ト名以外にも変更が必要な箇所があるとか？ですかね。 （はっしー） 2015/03/16(月) 22:43
なかなかすっきり行きませんね。 当然、（はっしー）さん もいそがなきゃいけないでしょうから、提案です。
このスレ、βのＶＢＡで、だいぶ進んでしまってます。 関数エキスパートさんたちも、ちょらっとのぞいても、あぁ、ＶＢＡかということで スルーしておられるかもしれません。
ですから、このスレとは別に新規スレを、表題を【関数で】と強調したものにして立ち上げ そこで、関数エキスパートさんたちからの回答をもらってはいかがでしょう。
で、（はっしー） さんとしては、それで、いっぱい、いっぱいでしょうけど、余裕があれば 以下もやっていただければありがたいです。
１．Sheet1とSheet2を持つ、新規ブックに、以下のマクロをコピペし実行。
A～DDまでの表A、表B(内容はいいかげんですが）を作り出します。
２．Sheet1のシートモジュールに、アップ済みのシートモジュールコードを貼り付けてください
３．で、Sheet1の D11 に 3/1 とか 3/2 とか いれて、B12,B13,B14,・・・に A5とかB20 とか
作り上げた表A,Bにあるコードをいれてみてください。
Sub MakeData()
'A,BB,BC,DD
With Sheets("Sheet2")
.Cells.Clear
.Range("A1").Value = "AAA"
.Range("B1").Value = DateValue("2015/3/1")
.Range("B1:BB1").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
.Range("A2:B100").Formula = "=""A""&ROW()-1"
.Range("A2:B100").Value = .Range("B2:B100").Value
.Range("B2:BB100").Formula = "=ROW()*COLUMN()"
.Range("B2:BB100").Value = .Range("B2:BB100").Value
.Range("BC1").Value = "BBB"
.Range("BD1").Value = DateValue("2015/3/1")
.Range("BD1:DD1").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
.Range("BC2:BD100").Formula = "=""B""&ROW()-1"
.Range("BC2:BD100").Value = .Range("BC2:BD100").Value
.Range("BD2:DD100").Formula = "=ROW()*COLUMN()"
.Range("BD2:DD100").Value = .Range("BD2:DD100").Value
End With
End Sub
（β） 2015/03/17(火) 06:04
β様、お世話になってます。 いろいろと考えて頂きありがとうございます。
只今、出先なので夜帰ってから検討します。 （はっしー） 2015/03/17(火) 12:45
もう１つ、考えられること。
外部から送られたファイルを処理する際によく、躓いてしまう現象ですが
日付行、 3/1 とか 3/2 とか、これらが、「文字列」になっている。 一方、検索用のシートの日付は、操作者が入力するので 3/1 を入れると 2105/3/1 という日付型になる。 これだと、絶対にマッチしない。
あるいは、先方の 3/1 も日付型だったとして、そのデータの実際の中身は 2014/3/1 とか。 一方、検索用シートで 3/1 といれると、それは 2015/3/1 になるので、これまた 絶対にマッチしない。
あるいは、各表の１列目のコード。 先方のコードには、後ろに、スペースなんかが入っている。あるいは目に見えないゴミ（特殊制御文字等）がはいっている。 これまた、絶対にマッチしない。
（β） 2015/03/17(火) 15:27
β様、お世話になっております。
日付に関して確認しました。 元ファイル、コピーしたシート（表A、Bのシート）共に 3/1 は 2015/3/1 でした。 また、日付の前後にスペース、特殊制御文字等はありませんでした。
2015/03/15(日) 21:02で教えていただいたコードで
[ Set r = Sheets("Sheet2").Range("A1").CurrentRegion '★表A,Bがあるシート。実際の名前に変更。]
の Sheet2 にはシートタブから名前をコピペ で問題ないと思いますが、 A1 は、表の位置、配置などに関係してるものなのかと...？
それから 2015/03/17(火) 06:04 で提案頂いた【関数で】で新スレ立ててみます。 （はっしー） 2015/03/18(水) 00:00
関数で回答がもらえることを期待しましょう！
もし、余裕があれば、（β） 2015/03/17(火) 06:04 でお願いした新規ブックでの確認もしていただければ うれしいです。
（β） 2015/03/18(水) 05:39
β様、お世話になっております。
上記マクロ、新規ブックで試したところ正常に動作しました。 2015/03/17(火) 06:04のコードを実際の表のセルの位置関係に合わせれば可能なような気がします。 （はっしー） 2015/03/20(金) 01:54
>2015/03/17(火) 06:04のコードを実際の表のセルの位置関係に合わせれば可能なような気がします。
それが目的です。 私が作り上げたレイアウトと実際のレイアウトではどこが異なっていましたか？
（β） 2015/03/20(金) 06:03
β様お世話になります。 いろいろと面倒お掛けして申し訳ありません。
こちらのスレでは引き続きVBAを進めて行きたく思います。
>私が作り上げたレイアウトと実際のレイアウトではどこが異なっていましたか？
（Sheet1) 表A項目表題 実際：B2 サンプル（β作）：A1 表A日付先頭 実際：D2 サンプル：B1 表Aデータ先頭最上段 実際：D3 サンプル：B2
表B項目表題 実際：BQ2 サンプル（β作）：BC1 表B日付先頭 実際：BS2 サンプル：BD1 表Bデータ先頭最上段 実際：BS3 サンプル：BD2
これは表のある3シートの中の１つで３シートとも微妙にセル位置が違います。上記をSheet1とします。 ほかに、 （Sheet2) 表A項目表題 実際：A2 サンプル：A1 表A日付先頭 実際：C2 サンプル：B1 表Aデータ先頭最上段 実際：C3 サンプル：B2
表B項目表題 実際：BO2 サンプル：BC1 表B日付先頭 実際：BQ2 サンプル：BD1 表Bデータ先頭最上段 実際：BQ3 サンプル：BD2
（Sheet3)このシートは表がひとつなので参考まで。 表項目表題 実際：B3 サンプル：A1 表日付先頭 実際：D3 サンプル：B1 表データ先頭最上段 実際：D4 サンプル：B2
この様になってます。
それから、実際の表は３シートとも共通ですが、各型番行は２行で１項目になっています。 その２行の上段が計画数で今回検索したい必要データです。下段は在庫数で、今回は必要ないデータです。
あと、私の認識違いで申し訳なかったのですが、Sheet2の表には表Aと表Bの間に一列空欄列が存在しました。
出力用のシートはSheet4になります。 出力用では日付入力位置がD1です。表は日付欄がD11～I11（元表の日付に合わせ６日分） 項目欄はB：Cでセルの結合してます。B12～C55まで。
以上のような情報で大丈夫でしょうか？宜しくお願い致します。
（はっしー） 2015/03/22(日) 00:25
ありがとうございます。 今から、じっくりとレイアウトを検証します。
ところで、別スレでも話題になっていた、各表の起点セル（左上隅のセル）に名前を付けることができれば VBA でも、融通性が格段とアップします。少々のレイアウトの双方のいきちがいも吸収できる部分が多くなります。
（β） 2015/03/22(日) 06:41
まず、ざっと流し読み。印象としては、「ひゃ～、これはだめだよね」
いろいろありますが、特に、各データが２行１組。これって、説明なかったですよね。 （はっしー） 2015/03/15(日) 12:25 で提示してもらったレイアウトは１行で１データだったし。 別スレの皆さんも、これはわかっているのでしょうか？ 心配。
で、表のレイアウトは、今回の説明で調整するとして、基本的に、今まで提示したコードは
・表A、表B がある、「１つのシート」（コードの中では"Sheet2"にしていますが、シート名は別にして１つのシート）に対して 日付や型番をいれて、表A、表B を参照して値をもってくるシート（このシートのシートモジュールに提示したコードがはりつけられる） この２つだけで構成される状態での処理です。
・その同じコードでレイアウトの異なるものを、単に、シート名を変えただけで動かしても、機能しないのは当然です。 （これは別スレの関数でも同じことです。そこも別スレのみなさんに伝わっているのかなぁ・・？）
なので、これからコードを新レイアウト（私から見れば新レイアウト）にあわせて改訂してみますが あくまで、（はっしー） 2015/03/22(日) 00:25の例でいえば、(Sheet1) のみを対象とします。
たぶん、いままで、こちらが扱ってきたシートは、（レイアウトのずれはあるとしても）(Sheet2) だったんでしょうかね？
●各表の左上隅セルに名前があれば、(Sheet1) と (Sheet2) を なんとか共通処理で、１つのロジックでも対応できるかも。 でも、これらは同じブックにあるのでしょうから、同じ名前では具合悪いですね。そうすると、たとえば 表A1 とか 表A2 という名前にする。 その場合、検索日付や検索型番をいれて処理する際に、どちらのシート（名前）を参照するかの指定も操作者にしてもらう必要がでてきますが。
★もう１つ。提案なんですが、提示の３つの様式の表、これらがあるブックをそれぞれ別ブックにして 運用すればいかがですか？ そうすれば、それぞれ、異なったコードを書くことになりますが、それぞれのブックで確実な処理ができますよ。
（β） 2015/03/22(日) 07:26
追加で
型番、２行で１組ということですが、その型番が入っているセルのそのもは
・セル結合 されているのですか？ ・結合なしで 上のセルだけに型番が入っているのですか？ ・結合なしで 上のセルにも下のセルにも型番がはいっているのですか？
（β） 2015/03/22(日) 08:38
もしかして、やろうとしていることは、検索用シートに日付や型番をいれると
Sheet1の表A,表Bを検索、なければSheet2の表A,表Bを検索、なければSheet3 の表A を検索。
そういうこと？ それならそれで、できないことはないけど。
（β） 2015/03/22(日) 10:50
レイアウトの理解が完全かどうか、まだ心もとないんですがとにかく試してみてください。 また、要件（仕様）も、勘違いしているかも。
検索用のシートのシートモジュールに以下コードを。
検索用シートの所定の領域（D11 あるいは B12～B55) に値が入れば自動実行。 検索順（優先順位）は、Sheet1のA表-->Sheet1のB表-->Sheet2のA表-->Sheet2のB表-->Sheet3のA表です。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim inR As Range
Dim flag As Boolean
Dim ListA1 As Range
Dim ListB1 As Range
Dim ListA2 As Range
Dim ListB2 As Range
Dim ListA3 As Range
Dim z1 As Range
Dim z2 As Range
Dim dt As Range
Dim c As Range
If Not Intersect(Target, Range("D11")) Is Nothing Then
If Not IsDate(Range("D11")) Then
MsgBox "正しい日付をいれてください"
Exit Sub
End If
Set inR = Range("B12:B55")
flag = True
Else
Set inR = Intersect(Target, Range("B12:B55"))
If inR Is Nothing Then Exit Sub
End If
'各表の領域をセット
With Sheets("Sheet1")
Set z1 = .Range("D2").End(xlToRight)
Set ListA1 = .Range(.Range("B2", .Range("B" & Rows.Count).End(xlUp)), z1)
Set z2 = .Cells(2, Columns.Count).End(xlToLeft)
Set ListB1 = .Range(.Range(z1.Offset(, 2), .Cells(Rows.Count, z1.Offset(, 2).Column).End(xlUp)), z2)
End With
With Sheets("Sheet2")
Set z1 = .Range("C2").End(xlToRight)
Set ListA2 = .Range(.Range("C2", .Range("C" & Rows.Count).End(xlUp)), z1)
Set z2 = .Cells(2, Columns.Count).End(xlToLeft)
Set ListB2 = .Range(.Range(z1.Offset(, 2), .Cells(Rows.Count, z1.Offset(, 2).Column).End(xlUp)), z2)
End With
With Sheets("Sheet3")
Set z1 = .Range("D3").End(xlToRight)
Set ListA3 = .Range(.Range("B3", .Range("B" & Rows.Count).End(xlUp)), z1)
End With
Application.EnableEvents = False
If flag Then
inR.Offset(0, 2).Resize(, 4).ClearContents
Range("D11:G11").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
End If
For Each c In inR
If c.Value <> "" Then
c.Offset(, 2).Resize(, 4).ClearContents
For Each dt In Range("D11:G11")
If Not DoSearch(c, dt, ListA1) Then
If Not DoSearch(c, dt, ListB1) Then
If Not DoSearch(c, dt, ListA2) Then
If Not DoSearch(c, dt, ListB2) Then DoSearch c, dt, ListA3
End If
End If
End If
Next
End If
Next
Application.EnableEvents = True
End Sub
Private Function DoSearch(c As Range, d As Range, listR As Range) As Boolean
Dim i As Variant
Dim j As Variant
With listR
i = Application.Match(c.Value, .Columns(1), 0)
If IsError(i) Then Exit Function
j = Application.Match(d.Value2, .Rows(1), 0)
If IsError(j) Then Exit Function
Intersect(c.EntireRow, d.EntireColumn).Value = listR.Cells(i, j).Value
DoSearch = True
End With
End Function
（β） 2015/03/22(日) 15:16
β様、お世話になっております。
>いろいろありますが、特に、各データが２行１組。これって、説明なかったですよね。 説明不足で誠に申し訳ありませんでした。最初は簡単な説明でも大丈夫かなと、勝手に判断して横着してしまいました。すみません。
>たぶん、いままで、こちらが扱ってきたシートは、（レイアウトのずれはあるとしても）(Sheet2) だったんでしょうかね？ 私の説明（2015/03/22(日) 00:25）でいうSheet1のことを前提に話してました。
> ●各表の左上隅セルに名前があれば、(Sheet1) と (Sheet2) を なんとか共通処理で、１つのロジックでも対応できるかも。 別レスの方の1111様アドバイスにより、名前の定義はできてます。 名前を付けた部分は（（1111） 2015/03/19(木) 11:17 ）レス指示部分です。
>★もう１つ。提案なんですが、提示の３つの様式の表、これらがあるブックをそれぞれ別ブックにして運用すればいかがですか？ 「もともとメール添付で1ブック３シート形式で送られて来るものを別ブックに分けてコピー貼り付けする」ということですか？ それはできれば避けたいです。
> 型番、２行で１組ということですが、その型番が入っているセルのそのもは >・セル結合 されているのですか？ 型番列は２行分毎にセル結合されてます。データ範囲は上行に計画数（今回検索したい数字）、下行に在庫数（今回 不必要な数字）が入ってます。
>Sheet1の表A,表Bを検索、なければSheet2の表A,表Bを検索、なければSheet3 の表A を検索。 Sheet1、Sheet2、Sheet3はそれぞれ別の型番です。重複はしません。
いろいろと、説明が不足して面倒お掛けします。 （はっしー） 2015/03/22(日) 19:36
>Sheet1、Sheet2、Sheet3はそれぞれ別の型番です。重複はしません。
はい、わかっています。それ以前に、きっと 同じシート上の 表A と 表B も重複しないんですよね。
確認したかったのは、１つのブックにSheet1,2,3 があって、それとは別に検索用のシートがあるのかな？ で、検索用シートの所定の場所に型番や日付をいれれば、これらのシートの表を探しに行って、いずれかにマッチしたものを 表示する。こんな要件なのかな？
で、そういう要件であれば、（β） 2015/03/22(日) 15:16 でアップしたコードで対応できますよということです。
いやいや、そうではなく、ブックには Sheet1,2,3のいずれしかない ということなら 本トピで相手にすべき表は Sheet1,2,3 のいずれですか？ （β） 2015/03/22(日) 20:07
β様、お世話になってます。
上記内容で大筋合ってます。 それで 2015/03/22(日) 15:16 でアップしたコードをコピペし、Sheet1、2、3 をそれぞれのシート名に 変更しました。 データが表示されないのですが、他に変更するところはありますか？ （はっしー） 2015/03/22(日) 21:51
コードは日付や型番をいれて抽出処理をする、そのシートのシートモジュールに貼り付けてもらいましたか？
そうしても、表示されないということだと、まだまだ、こちらがレイアウトを理解していないということになります。
（β） 2015/03/22(日) 22:04
こちらでテストしているシートのレイアウトは以下の通りです。(とりあえず Sheet1のみ） 表B の開始桁は、固定ではないので、たまたま、こちらのデータがそうなっていると受け止めて下さい。 空白列の関係、行の関係を確認してください。
Sheet1
B2 機種名 B3から下のB列は、２行単位でセル結合。型番が入っている。 C列は空白列 D2～BD2 まで日付 D3～BD〇まで数字
ここまでが 表A
BE列が空白列
ここから 表B
BF2 機種名 BF3から下のBF列は、２行単位でセル結合。型番が入っている。 BG列は空白列 DH2～DH2 まで日付 BH3～DH〇まで数字
（β） 2015/03/22(日) 22:17
β様、お世話になっております。
上記のものでSheet1の位置関係は問題ないです。合っています。
>DH2～DH2 まで日付 BH2～DH2ですね。
あと、空白欄には実際は上行に計画数、下行に在庫と入っているだけです。 空白欄最上行には生産日と入力されてます。 （はっしー） 2015/03/22(日) 22:35
>BH2～DH2ですね。
はい、そうでした。ごめん。
> 空白欄最上行には生産日と入力されてます。
C2,BG2 のことですか？ BE2 もそうですか？
で、SHeet1 にある型番と日付をいれても、表示されなかったということですね？
それと、コードはどこに張り付けてもらってますか？
なお、Sheet2 は、A2 を起点として Sheet1 を １列 左にずらした形、 Sheet3 はB3 を起点にして Sheet1 を 1行 下にずらした形（Sheet3 は 表A のみ） になっています。
（β） 2015/03/23(月) 05:56
表A、表B の空白列の先頭（こちらの例では C2,BG2) に日付といれても、こちらでは値が参照できています。 ただし、表Aと表Bの間の空白列に（こちらの例ではBE2）に値があると、表B の検索はできません。
まず、SHeet1のA表にあるものをいれてみてください。
（β） 2015/03/23(月) 06:30
お世話になってます。
私事で大変申し訳ありませんが仕事でトラブルがあり、急な出張中です。 日にちがあいてしまって放置状態ですが、明日、ないし明後日には戻って再開できると思いますので、宜しくお願い致します。 （はっしー） 2015/03/25(水) 22:29
β様、お世話様です。それからかなり間が空き、その間何も応答できず誠に申し訳なく思ってます。 お気を害されているかもしれませんが、引き続きご教授お願いできませんでしょうか？
2015/03/23(月) 06:30までのレスを見直し検索結果が”ほぼ”表示されるようになりました。 これまでありがとうございます。
あと少しです。
使用コードは 2015/03/22(日) 15:16でご提示されたものを使用したものです。 検索結果が表示されないパターンがあります。2015/03/22(日) 00:25のレイアウト内容で説明しますと （1）シート2表B 型番名欄（項目表題）がBGの場合表Bの検索結果が表示されません。（因みにBF列は空欄。BFは表Aと表Bの境界線になってます。） （2）シート1表Bはどの列番でも検索結果が表示されません。（因みにシート1表Aと表Bの境には空欄列はありません。 2015/03/23(月) 06:30のとおりの結果です） （3）元表は土日も含む全ての日付が入ってますが必要な（表示させたい）のは平日（祭日含む）で土日は省いて結果を表示させたいです。 （4）検索結果を４日分表示を６日分表示に変更したいです。
以上、宜しくお願い致します。 （はっしー） 2015/04/12(日) 00:12
間があいたので、ほとんど忘却のかなた（？） 環境再整備と要件を思い出すためのキャッチアップに少し時間ください。
（β） 2015/04/12(日) 06:51
β様、お世話様です。 いろいろあり１か月弱も空いてしまったので無理もないです。恐縮です。
それから若干の変更もあり、今後あまり時間もかけていられない状況になり、またこちらのＶＢＡでの方法がかなり完成に近づいてることから こちら一本に絞らせて頂こうと思います。
お忙しい中、お手間を掛けてしまい申し訳ありませんが何卒宜しくお願いします。 （はっしー） 2015/04/12(日) 09:30
今までのやり取りを追いかけながらレイアウトを起こしてみました。 3/22(00:25)で確認したレイアウトだと、作成が面倒なので日付は１０個のみの小さな表にしてあります。
>ただし、表Aと表Bの間の空白列に（こちらの例ではBE2）に値があると、表B の検索はできません。
こう、コメントしている通り、こういう状態なら表Bの検索はできないコードなので、「検索できない」のは ある意味、「正常」です。
> （3）元表は土日も含む全ての日付が入ってますが必要な（表示させたい）のは平日（祭日含む）で土日は省いて結果を表示させたいです。 > （4）検索結果を４日分表示を６日分表示に変更したいです。
この追加仕様は、まず、そのほかがうまくいってから対応しましょう。
で、念のため、今、手元で作成したレイアウトを以下に記載します。各シートには、【これ以外に値が入っているセルはない】という前提です。 レイアウトがあっているのかどうか、最終確認願います。
Sheet1
B2 機種名 B3～B28 2セル結合で型番 C2 日付タイトル D2～M2 日付 D3～M28 数値
O2 機種名 O3～O28 2セル結合で型番 P2 日付タイトル Q2～Z2 日付 Q3～Z28 数値
Sheet2
A2 機種名 A3～A28 2セル結合で型番 B2 日付タイトル C2～L2 日付 C3～L28 数値
N2 機種名 N3～N28 2セル結合で型番 O2 日付タイトル P2～Y2 日付 P3～Y28 数値
Sheet3
B3 機種名 B4～B29 2セル結合で型番 C2 日付タイトル D2～M2 日付 D3～M28 数値
（β） 2015/04/12(日) 16:59
β様、お世話様です。
Sheet1 表A最後列M列と表最前列O列となってますが、実際の表にはN列部分（空欄列）がありません。
Sheet2 問題ありません。
Sheet3 >C2 日付タイトル →C3 >D2～M2 日付 →D3～ >D3～M28 数値 →D4～
確認内容は以上です。宜しくお願いします。 （はっしー） 2015/04/12(日) 20:13
レイアウト、Sheet3は、私の確認コメントの記載ミスで、実際には、（はっしー） 2015/04/12(日) 20:13 で指摘いただいた通りのレイアウトでした。 つまり、Sheet2,Sheet3はそちらのレイアウトとこちらの理解が一致。 ただし、Sheet2の表A領域に関するコードにミスあり、訂正。 Sheet1 は、表Aと表Bの間に空白列がないということで、これは初めて聞いたような気がしますがいずれにしても アップしたコードでは対応できていませんね。
ただ、それでも、（はっしー）2015/04/12(日) 00:12 で報告のあった結果が、こちらの（現行コードでの）結果と異なるので まだ、どこかに誤解があるかも？
いずれにしても、以下、再掲しますので試してみてください。 なお、コメントしたように、（はっしー） 2015/04/12(日) 00:12 の (3)、(4) は未対応です。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim inR As Range
Dim flag As Boolean
Dim ListA1 As Range
Dim ListB1 As Range
Dim ListA2 As Range
Dim ListB2 As Range
Dim ListA3 As Range
Dim z1 As Range
Dim z2 As Range
Dim dt As Range
Dim c As Range
Dim r As Range
If Not Intersect(Target, Range("D11")) Is Nothing Then
If Not IsDate(Range("D11")) Then
MsgBox "正しい日付をいれてください"
Exit Sub
End If
Set inR = Range("B12:B55")
flag = True
Else
Set inR = Intersect(Target, Range("B12:B55"))
If inR Is Nothing Then Exit Sub
End If
'各表の領域をセット
With Sheets("Sheet1")
Set r = .Range("B2").CurrentRegion.Rows(1).SpecialCells(xlCellTypeConstants, 1)
Set z1 = r.Areas(1).Cells(r.Areas(1).Cells.Count)
Set ListA1 = .Range(.Range("B2", .Range("B" & Rows.Count).End(xlUp)), z1)
Set z2 = r.Areas(2).Cells(r.Areas(2).Cells.Count)
Set ListB1 = .Range(.Range(z1.Offset(, 1), .Cells(Rows.Count, z1.Offset(, 1).Column).End(xlUp)), z2)
End With
With Sheets("Sheet2")
Set z1 = .Range("C2").End(xlToRight)
Set ListA2 = .Range(.Range("A2", .Range("A" & Rows.Count).End(xlUp)), z1)
Set z2 = .Cells(2, Columns.Count).End(xlToLeft)
Set ListB2 = .Range(.Range(z1.Offset(, 2), .Cells(Rows.Count, z1.Offset(, 2).Column).End(xlUp)), z2)
End With
With Sheets("Sheet3")
Set z1 = .Range("D3").End(xlToRight)
Set ListA3 = .Range(.Range("B3", .Range("B" & Rows.Count).End(xlUp)), z1)
End With
Application.EnableEvents = False
If flag Then
inR.Offset(0, 2).Resize(, 4).ClearContents
Range("D11:G11").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
End If
For Each c In inR
If c.Value <> "" Then
c.Offset(, 2).Resize(, 4).ClearContents
For Each dt In Range("D11:G11")
If Not DoSearch(c, dt, ListA1) Then
If Not DoSearch(c, dt, ListB1) Then
If Not DoSearch(c, dt, ListA2) Then
If Not DoSearch(c, dt, ListB2) Then DoSearch c, dt, ListA3
End If
End If
End If
Next
End If
Next
Application.EnableEvents = True
End Sub
Private Function DoSearch(c As Range, d As Range, listR As Range) As Boolean
Dim i As Variant
Dim j As Variant
With listR
i = Application.Match(c.Value, .Columns(1), 0)
If IsError(i) Then Exit Function
j = Application.Match(d.Value2, .Rows(1), 0)
If IsError(j) Then Exit Function
Intersect(c.EntireRow, d.EntireColumn).Value = listR.Cells(i, j).Value
DoSearch = True
End With
End Function
（β） 2015/04/12(日) 21:53
土日を除く６日間対応。DoSearchは変更なし。Worksheet_Change を以下でリバイスして試してください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim inR As Range
Dim flag As Boolean
Dim ListA1 As Range
Dim ListB1 As Range
Dim ListA2 As Range
Dim ListB2 As Range
Dim ListA3 As Range
Dim z1 As Range
Dim z2 As Range
Dim dt As Range
Dim c As Range
Dim r As Range
Dim d As Date
Dim w(1 To 6) As Date
Dim i As Long
If Not Intersect(Target, Range("D11")) Is Nothing Then
If Not IsDate(Range("D11")) Then
MsgBox "正しい日付をいれてください"
Exit Sub
End If
Set inR = Range("B12:B55")
flag = True
Else
Set inR = Intersect(Target, Range("B12:B55"))
If inR Is Nothing Then Exit Sub
End If
'各表の領域をセット
With Sheets("Sheet1")
Set r = .Range("B2").CurrentRegion.Rows(1).SpecialCells(xlCellTypeConstants, 1)
Set z1 = r.Areas(1).Cells(r.Areas(1).Cells.Count)
Set ListA1 = .Range(.Range("B2", .Range("B" & Rows.Count).End(xlUp)), z1)
Set z2 = r.Areas(2).Cells(r.Areas(2).Cells.Count)
Set ListB1 = .Range(.Range(z1.Offset(, 1), .Cells(Rows.Count, z1.Offset(, 1).Column).End(xlUp)), z2)
End With
With Sheets("Sheet2")
Set z1 = .Range("C2").End(xlToRight)
Set ListA2 = .Range(.Range("A2", .Range("A" & Rows.Count).End(xlUp)), z1)
Set z2 = .Cells(2, Columns.Count).End(xlToLeft)
Set ListB2 = .Range(.Range(z1.Offset(, 2), .Cells(Rows.Count, z1.Offset(, 2).Column).End(xlUp)), z2)
End With
With Sheets("Sheet3")
Set z1 = .Range("D3").End(xlToRight)
Set ListA3 = .Range(.Range("B3", .Range("B" & Rows.Count).End(xlUp)), z1)
End With
Application.EnableEvents = False
If flag Then
inR.Offset(0, 2).Resize(, 6).ClearContents
d = Range("D11").Value
For i = 1 To 6
Do
If Weekday(d) <> 1 And Weekday(d) <> 7 Then Exit Do
d = d + 1
Loop
w(i) = d
d = d + 1
Next
Range("D11:I11").Value = w
End If
For Each c In inR
If c.Value <> "" Then
c.Offset(, 2).Resize(, 6).ClearContents
For Each dt In Range("D11:I11")
If Not DoSearch(c, dt, ListA1) Then
If Not DoSearch(c, dt, ListB1) Then
If Not DoSearch(c, dt, ListA2) Then
If Not DoSearch(c, dt, ListB2) Then DoSearch c, dt, ListA3
End If
End If
End If
Next
End If
Next
Application.EnableEvents = True
End Sub
（β） 2015/04/12(日) 22:46
β様、お世話様です。
上記コード試してみたところ
>'各表の領域をセット
> With Sheets("Sheet1") 【⇐実際はシート名に書き換えてあります】
> Set r = .Range("B2").CurrentRegion.Rows(1).SpecialCells(xlCellTypeConstants, 1)
> Set z1 = r.Areas(1).Cells(r.Areas(1).Cells.Count)
> Set ListA1 = .Range(.Range("B2", .Range("B" & Rows.Count).End(xlUp)), z1)
> Set z2 = r.Areas(2).Cells(r.Areas(2).Cells.Count)
> Set ListB1 = .Range(.Range(z1.Offset(, 1), .Cells(Rows.Count, z1.Offset(, 1).Column).End(xlUp)), z2)
> End With
このコードの Set z2 = r.Areas(2).Cells(r.Areas(2).Cells.Count) で、プログラムが止まり、「実行時エラー'1004':アプリケーション定義またはオブジェクト定義のエラーです。」と表示されます。
どこをどう修正してよいものかわかりません。確認お願いします。
（はっしー） 2015/04/13(月) 00:46
実際に試した時の、そちらのSheet1の2行目のレイアウトを教えてください。
とくにB表の機種名のところ。ここが数字なら、こうなります。 Sheet1は、A,Bの間に空白列がないため、それぞれの領域の把握が、困難で コードでは、この行に数字（日付）の連続した塊が２つあって、それ以外は数字ではない文字列だと そういったことで判定しています。 これが無理なら、今のところ、お手上げです。
もし、A表、B表の日付が同じ列数なら、別の方法もありますが？
（β） 2015/04/13(月) 05:44
追伸
関数案のスレでセルに名前を付けるという話題があったかと思います。 現在、どこかのセルに名前がついているなら、どのセルにどんな名前が付いているか教えてください。
それと、念のため、こちらで使っているSheet1の2行目のレイアウトは以下です。
A2 : 空白 B2 : xxxxxx 機種名 数字ではない C2 : "生産日" というタイトル（文字列なら、なんでもいいです） D2～M2 日付 N2 : yyyyyy 機種名 数字ではない O2 : "生産日" というタイトル（文字列なら、なんでもいいです） P2～Y2 日付
（β） 2015/04/13(月) 06:21
β様、お世話様です。
Sheet1２行目は順を追って左側から
（表A） B2：機種名（実際には"728/729"と入ってます） C2："生産日"と入ってます D2～日付（4/10、4/11と入ってます） BW～BX:"備考欄"と入ってます （表B) BY：機種名（実際は"新社屋分"と入ってます） BZ:"生産日" CA～日付 ET～EU："備考欄"
尚、表A、表Bの日付は最初から最後まで同じ日付が入ってますので列数的にも同数です。
（はっしー） 2015/04/13(月) 06:32
連続レス、すいません。
B2：機種名（実際には"728/729"と入ってます）
これがまずいんですかね？
あと、名前の定義は今は消してしまったのですが、再度付けることは可能です。 （はっしー） 2015/04/13(月) 06:37
>BW～BX:"備考欄"と入ってます
これは何ですか？ このような項目の説明は今までなかったと思いますが？ （はっしー） 2015/04/12(日) 20:13 の確認レスにも、この説明はなかったですね？
必ず２列なんですか？で、結合セルなんですか？ ほかのシートの表も、こうなっているんですか？
ただ、そちらの説明のレイアウトにしても、少なくとも、こちらではエラーにはなりません。 領域の認識が違うので、検索シートで型番をいれても正しく参照されませんけど。
名前の定義は、にっちもさっちもいかなくなったら考えます。
（β） 2015/04/13(月) 06:52
β様、お世話様です。
>>BW～BX:"備考欄"と入ってます > >これは何ですか？ このような項目の説明は今までなかったと思いますが？ >（はっしー） 2015/04/12(日) 20:13 の確認レスにも、この説明はなかったですね？
今年度分（４月分）から送られてくる表から付きました。追加説明忘れてました。すみません。 すべてのシートのすべての表の最後列に２列で付いてます。
このあと、次のレスは申し訳ありませんが夜になってしまいます。ご了承ください。
（はっしー） 2015/04/13(月) 07:25
まず、今のコードのままで、
>'各表の領域をセット
> With Sheets("Sheet1") 【⇐実際はシート名に書き換えてあります】
> Set r = .Range("B2").CurrentRegion.Rows(1).SpecialCells(xlCellTypeConstants, 1)
この下に
MsgBox r.Address
を追加して、検索シートに何か入れて、コードが動いたときにどんなアドレス表示がされるか教えてください。
備考の件はわかりました。どうやるか、少し考えます。
もう１つ。 以下のコードを実行して（シート名は変更してくださいね） 表示される３つのアドレスを教えてください。 で、あわせて、各シートの表A,B の実際の領域（機種名から備考の２列目の最後の行までの領域）を教えてください。
Sub 確認()
With Sheets("Sheet1")
MsgBox .Range("B2").CurrentRegion.Address
End With
With Sheets("Sheet2")
MsgBox .Range("A2").CurrentRegion.Address
End With
With Sheets("Sheet3")
MsgBox .Range("B3").CurrentRegion.Address
End With
End Sub
（β） 2015/04/13(月) 15:47
β様、お世話様です。 >MsgBox r.Address > >を追加して、検索シートに何か入れて、コードが動いたときにどんなアドレス表示がされるか教えてください。
$ET$1 と表示されました。
その下の"Sub 確認()"から始まるコードは検索用シートのシートモジュールに貼り付けして実行ですか？ （はっしー） 2015/04/13(月) 21:14
標準モジュールでお願いします。
しかし・・・・ｒ のアドレスが ET1 とは・・・・？？？？
Sheet1のB2から連続している領域の、その最初の行は２行目だと思っているんですが？ １行目は空白行なんですよね？ ET1 と表示されるということは ET1 に数字があるということなんですが？ そうなっているんですか？
とにかく、正確な状態がわからないことには、手の打ちようもないですよ。
（β） 2015/04/13(月) 21:50
>表示される３つのアドレスを教えてください。
$A$1:$EU$177 $A$1:$BU$40 $B$2:$BD$115
>あわせて、各シートの表A,B の実際の領域（機種名から備考の２列目の最後の行までの領域）を教えてください。 Sheet1表A：B2～BX67（45行目に２行目同様の日付入ってます。機種名欄は別機種名）⇐今回、気づいた所です。（この45行目の存在が悪影響しなければよいのですが...）
Sheet1表B：BY2～EU50 （55行目から今回不必要な別な表があります）
Sheet2表A：A2～BU40 （42行目から今回不必要な別な表があります）
Sheet2表B：BW2～EN48
Sheet3表：B3～BC109
（はっしー） 2015/04/13(月) 22:07
Sheet1 ET1:EU1 には発行日が記入されてます（表の外側です） （はっしー） 2015/04/13(月) 22:11
領域の特定方法はいろいろありますが、それぞれの実態に合わせて、「正しく」取得しなければいけません。
私のコードでは、CurrentRegion を多用しています。これは、「隣接している１塊の領域」を取得しますので 「表の外側」であっても「隣接」していれば、表の一部だとみなします。 Sheet1のみならず、Sheet2.SHeet3も「隣接して」表の１行上にデータがあるようですね。
さらにSHeet1の場合、「空白列」だと思っていた「A列」にも、なにか値が入っているところがあるようですね。
表の下に、隣接はしていないけど、別の表があるということも、領域取得のコードをどう書くかということに 大きく影響します。
「表の上は空白行」等々の説明を頼りに、アップしたコードにしましたが、領域把握の部分を書き直しますので、少し時間ください。
追記 6:40
そちらでの領域確認メッセージで、まだ気になるところがあります。
・Sheet1 表B は 50行目までということですが、表A についてメッセージでは EU177まで、つまり 177行目まで。 これは、表Aは177行目まである。一方、表Bは50行目までしかないということですか。 それならそれでいいですが。
・Sheet3 109 行目までとうことですが、メッセージは 115 行目までとなっています。 110行目以降、「隣接して」何か値が入っているのですか？ また、列はBC列までのところ、メッセージでは BD列まで。この差異について、何か思い当るところはないですか？ （Sheet1,Sheet2 では、実際の列とメッセージの列は一致しています）
（β） 2015/04/14(火) 05:36
β様、お世話様です。
度重なる手間をお掛けしてすみません。
送られてくるファイルには自社用以外に複数の他社へも同じものが送られているようで、その中で自社に適応する機種、型番だけを抜粋する感じです。 なので不必要な部分は今まではしっかり把握してませんでした。
今更ながら安直な説明の付けたしのような対応で大変恐縮しています。
このあとの返答は夜分になってしまいますが、必要であればその時にファイルの各シート内全体の状況を調べ直し、改めて説明させて頂きたいと思います。 （はっしー） 2015/04/14(火) 06:48
こちらからの質問の回答を受けてからのほうがいいかもしれませんが、表に隣接してあたいがあったとしても なんとか、別のやり方で領域を取得。 ただし、各表の機種名は【エクセルにとっての数値】ではないことが前提。 123/567 等はＯＫ。 また、各表の最終行は、各表の最初の日付列で、上から調べて値がある最後の行という判断に変えました。 かりに、どこかに空白セルがあれば、その下は無視されます。
DoSearch は変更有りません。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim inR As Range
Dim flag As Boolean
Dim listA1 As Range
Dim listB1 As Range
Dim listA2 As Range
Dim listB2 As Range
Dim listA3 As Range
Dim z1 As Range
Dim z2 As Range
Dim dt As Range
Dim c As Range
Dim r As Range
Dim d As Date
Dim w(1 To 6) As Date
Dim i As Long
Dim dtR As Range
Dim x As Long
If Not Intersect(Target, Range("D11")) Is Nothing Then
If Not IsDate(Range("D11")) Then
MsgBox "正しい日付をいれてください"
Exit Sub
End If
Set inR = Range("B12:B55")
flag = True
Else
Set inR = Intersect(Target, Range("B12:B55"))
If inR Is Nothing Then Exit Sub
End If
'各表の領域をセット
With Sheets("Sheet1")
Set dtR = .Range("B2", .Cells(2, Columns.Count).End(xlToLeft))
Set dtR = dtR.SpecialCells(xlCellTypeConstants, 1)
x = dtR.Areas(1).Cells(1).End(xlDown).Row
Set listA1 = dtR.Areas(1).Offset(, -2).Resize(x - 1, dtR.Areas(1).Cells.Count + 2)
x = dtR.Areas(2).Cells(1).End(xlDown).Row
Set listB1 = dtR.Areas(2).Offset(, -2).Resize(x - 1, dtR.Areas(2).Cells.Count + 2)
End With
With Sheets("Sheet2")
Set dtR = .Range("A2", .Cells(2, Columns.Count).End(xlToLeft))
Set dtR = dtR.SpecialCells(xlCellTypeConstants, 1)
x = dtR.Areas(1).Cells(1).End(xlDown).Row
Set listA2 = dtR.Areas(1).Offset(, -2).Resize(x - 1, dtR.Areas(1).Cells.Count + 2)
x = dtR.Areas(2).Cells(1).End(xlDown).Row
Set listB2 = dtR.Areas(2).Offset(, -2).Resize(x - 1, dtR.Areas(2).Cells.Count + 2)
End With
With Sheets("Sheet3")
Set dtR = .Range("B3", .Cells(3, Columns.Count).End(xlToLeft))
Set dtR = dtR.SpecialCells(xlCellTypeConstants, 1)
x = dtR.Areas(1).Cells(1).End(xlDown).Row
Set listA3 = dtR.Areas(1).Offset(, -2).Resize(x - 1, dtR.Areas(1).Cells.Count + 2)
End With
Application.EnableEvents = False
If flag Then
inR.Offset(0, 2).Resize(, 6).ClearContents
d = Range("D11").Value
For i = 1 To 6
Do
If Weekday(d) <> 1 And Weekday(d) <> 7 Then Exit Do
d = d + 1
Loop
w(i) = d
d = d + 1
Next
Range("D11:I11").Value = w
End If
For Each c In inR
If c.Value <> "" Then
c.Offset(, 2).Resize(, 6).ClearContents
For Each dt In Range("D11:I11")
If Not DoSearch(c, dt, listA1) Then
If Not DoSearch(c, dt, listB1) Then
If Not DoSearch(c, dt, listA2) Then
If Not DoSearch(c, dt, listB2) Then DoSearch c, dt, listA3
End If
End If
End If
Next
End If
Next
Application.EnableEvents = True
End Sub
（β） 2015/04/14(火) 18:43
β様、お世話様です。
上記（β） 2015/04/14(火) 18:43のコードを試したところ完璧に実行できました。更新前の前年度の表でも問題なく検索されました。 これなら検索ソフトとして使えます。 いろいろと至らないところばかりで心労をお掛けしました。大変感謝しています。
>かりに、どこかに空白セルがあれば、その下は無視されます。 元ファイルの表には予定数がない場合"0"が入力されているため検索可能なのだと思います。
本当に長い間、お世話になりました。途中、空白期間もあり忘却の彼方から呼び戻すようなこともさせてしまい、申し訳なく、またありがたく思っています。本当に助かりました。
また解らないことがあった時にはこんな私ですが宜しくお願い致しいます。 （はっしー） 2015/04/14(火) 23:37
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.