エクセル2010 同データの検索と関連セルの表示

先の質問、
http://oshiete.goo.ne.jp/qa/8405162.html

において、実践後の画像を再アップさせて頂きます。


まずは、S1セルに
=IF(INDEX($Y:$Y,ROW())="","",INDEX($Y:$Y,ROW())&"■"&COUNTIF(INDEX($Y:$Y,1):INDEX($Y:$Y,ROW()),INDEX($Y:$Y,ROW())))

を入力後、ctrl + ENTER で確定し、オートフィルで最下部まで。




その後、すべてctrl + ENTER で　以下を貼り付けました。

B9セル

=IF(INDEX($4:$4,COLUMN())="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN())),"",IF(INDEX($V:$V,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($V:$V,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

B10セル

=IF(INDEX($4:$4,COLUMN())="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN())),"",IF(INDEX($Z:$Z,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($Z:$Z,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

B11セル

=IF(INDEX($4:$4,COLUMN())="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN())),"",IF(INDEX($AA:$AA,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($AA:$AA,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

B12セル

=IF(INDEX($4:$4,COLUMN())="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN())),"",IF(INDEX($AC:$AC,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($AC:$AC,MATCH(INDEX($4:$4,COLUMN())&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

C9セル

=IF(INDEX($4:$4,COLUMN()-1)="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN()-1)),"",IF(COUNT(INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))),LOOKUP("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))),"")))

C9セルの書式設定の表示形式を[日付]に。


C10セル

=IF(ISERROR(1/(INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3)<>"")),"",INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3))

C11セル

=IF(INDEX($4:$4,COLUMN()-1)="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN()-1)),"",IF(INDEX($AB:$AB,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($AB:$AB,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

C12セル

=IF(INDEX($4:$4,COLUMN()-1)="","",IF(ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN()-1)),"",IF(INDEX($AD:$AD,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0))="","",INDEX($AD:$AD,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))))

機器Aの１回目は求める数値を抜き出して表示してくれています。

それを、コピー＆ペーストで　機器Bの１回目、機器Aの２回目に貼り付けました。
これは、オートフィルでも同じ数値が帰って来ます。

それで問題点なのですが、
機器Bの１回目、E9セルには１月１日と、E10セルには空白が帰って来ています。
また機器Aの２回目も同じ場所、C13セルが１月２日と、C14セルが空白で帰って来ています。

ちなみにE9セルの数式は

=IF(ISERROR(1/(INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3)<>"")),"",INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3))

E10セルの数式は
=IF(ISERROR(1/(INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3)<>"")),"",INDEX($U:$U,MATCH("9999/12/31"+1,INDEX($U:$U,1):INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)))+3))

となっています。

これで問題点が明らかになるでしょうか？

よろしくお願いいたします。

No.6 回答者： ki-aaa 回答日時： 2014/01/05 11:32

#1で回答したものです。

私のところでは、#1でも#3でも巧くいきました。

結論としては"B4:P4"にある機器名と"Y:Y"にある機器名が、等しくならない
見た目は同じでも前後にスペースが入ったり改行コードが入ったりしていると思われます。

差し替えて、実行してもらえますか?


Sub 配置換え()
Dim i As Long, j As Long, k As Long
Dim MaxRow As Long

Dim 機器名列 As Long, 試行回数 As Long, 関連データ行 As Long
Dim 機器名 As String
Dim myRange As Range, FindCell As Range


With Sheets("Sheet3") '実際のシート名にする

MaxRow = .Cells(Rows.Count, "Y").End(xlUp).Row 'Y列で最終行取得

'半角スペースと全角スペースの削除
.Range("Y1:Y" & MaxRow).Replace What:=" ", Replacement:="", LookAt:=xlPart '**2014/1/5追加
.Range("Y1:Y" & MaxRow).Replace What:="　", Replacement:="", LookAt:=xlPart '**2014/1/5追加
.Range("Y1:Y" & MaxRow).Replace What:=Chr(10), Replacement:="", LookAt:=xlPart '**2014/1/5追加
.Range("Y1:Y" & MaxRow).Replace What:=Chr(13), Replacement:="", LookAt:=xlPart '**2014/1/5追加

.Range(.Cells(9, "B"), .Cells(48, "Q")).ClearContents


For 機器名列 = 2 To 16 Step 2 '16・機器名が左詰で最大8種ある
機器名 = Trim(.Cells(4, 機器名列).Value) '**2014/1/5変更
If 機器名 = "" Then Exit Sub

'関連データの機器名列をmyRangeにセット
Set myRange = .Range(.Cells(1, "Y"), .Cells(MaxRow, "Y"))


For 試行回数 = 1 To 10
Set FindCell = myRange.Find(What:=機器名, After:=.Cells(MaxRow, "Y"), LookIn:=xlValue, LookAt:=xlWhole)
If FindCell Is Nothing Then Exit For
関連データ行 = FindCell.Row

.Cells(試行回数 * 4 + 5, 機器名列).Value = .Cells(関連データ行, "V").Value
.Cells(試行回数 * 4 + 6, 機器名列).Value = .Cells(関連データ行, "Z").Value
.Cells(試行回数 * 4 + 7, 機器名列).Value = .Cells(関連データ行, "AA").Value
.Cells(試行回数 * 4 + 8, 機器名列).Value = .Cells(関連データ行, "AC").Value

i = Int((関連データ行 - 1) / 8) * 8 '関連データデータグループ最初の行を求める
.Cells(試行回数 * 4 + 5, 機器名列 + 1).Value = .Cells(i + 1, "U").Value
.Cells(試行回数 * 4 + 6, 機器名列 + 1).Value = .Cells(i + 4, "U").Value
.Cells(試行回数 * 4 + 7, 機器名列 + 1).Value = .Cells(関連データ行, "AB").Value
.Cells(試行回数 * 4 + 8, 機器名列 + 1).Value = .Cells(関連データ行, "AD").Value

If 関連データ行 + 1 > MaxRow Then Exit For
Set myRange = .Range(.Cells(関連データ行 + 1, "Y"), .Cells(MaxRow, "Y"))
Next 試行回数


Next 機器名列
End With
End Sub

No.5 回答者： tom04 回答日時： 2014/01/05 09:47

No.3・4です。

前回の投稿で間違いがありました。
＞オブジェクト関数またはWithブロック変数が設定されていません
の場合、コードは黄色にならないと思います。

おそらく、Object型部分のエラーだと思いNo.3のような内容にしました。

何度も失礼しました。m(_ _)m

No.4 回答者： tom04 回答日時： 2014/01/05 09:37

No.3です。

試しに↓の画像のようにデータを作ってみて、前回投稿したコードをコピー＆ペーストしマクロを実行してみました。
問題なく、表示されています。

補足の
＞そして、マクロの実行をしましたが、【　オブジェクト関数またはWithブロック変数が設定されていません　】のエラーメッセージが出ます。

の件について・・・
エラーでマクロが途中で止まっている状態ですね。
どの行が黄色になっているでしょうか？

憶測ですが、
＞Set c = Range("A4:Q4").Find(What:=Cells(k, "Y"), LookIn:=xlValues, LookAt:=xlWhole)
の部分で止まっているのでは？
この行でB～Q列の何列目にデータを表示するか？を取得していますので、
完全一致しないといけません。
前回の質問では4行目・Y列は「検査機器○」だったような気がしますので
8行目の項目データとY列データが同じかどうか今一度確認してみてください。

次に
＞そして、B８～Q８セルに各々、　ダミー　の文字が出ます
については
途中でマクロが止まっているためにそのような表示がでています。

アップされている画像では8行目にデータがないのでストッパー代わりに8行目に仮のデータを表示させています。
これはその列の最終行を取得し、その1行下にデータを表示させるためです。
コードでは最後に8行目データは消去するようにしています。

※　VBAの場合、1行・1列違ったり、データが少しでも違うと全く意図しない動きになるコトがあります。
これは関数でも同じです。

具体的なエラーがこちらでは判らないので、あくまで憶測での回答になります。m(_ _)m

No.3 回答者： tom04 回答日時： 2014/01/04 22:05

こんばんは！

前回投稿した者です。

前回の配列数式で大丈夫だと思いますが・・・
今回はVBAでやってみました。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, c As Range
Application.ScreenUpdating = False
Range("B8:Q48").ClearContents
Range("B8:Q8") = "ダミー"
For i = 1 To Cells(Rows.Count, "V").End(xlUp).Row Step 8
For k = i To i + 7
If Cells(k, "Y") <> "" Then
Set c = Range("A4:Q4").Find(What:=Cells(k, "Y"), LookIn:=xlValues, LookAt:=xlWhole)
j = c.Column
If Cells(Rows.Count, j).End(xlUp).Row < 48 Then
With Cells(Rows.Count, j).End(xlUp).Offset(1)
.Value = Cells(k, "V")
.Offset(1) = Cells(k, "Z")
.Offset(2) = Cells(k, "AA")
.Offset(3) = Cells(k, "AC")
With .Offset(, 1)
.Value = Cells(i, "U")
.NumberFormatLocal = "m月d日" '←日付セルの表示形式は好みで！
End With
.Offset(1, 1) = Cells(i + 3, "U")
.Offset(2, 1) = Cells(k, "AB")
.Offset(3, 1) = Cells(k, "AD")
End With
End If
End If
Next k
Next i
Range("B8:Q8").ClearContents
Application.ScreenUpdating = True
End Sub 'この行まで

※　セルに数式が入っている場合、すべて消えてしまいますので、別Sheetでマクロを試してみてください。
※　関数でないのでデータ変更があるたびにマクロを実行する必要があります。m(_ _)m

この回答への補足

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


設定したいシートのタブで右クリック　コードの表示にコードを貼り付けしました。

そして、マクロの実行をしましたが、【　オブジェクト関数またはWithブロック変数が設定されていません　】のエラーメッセージが出ます。

そして、B８～Q８セルに各々、　ダミー　の文字が出ます。

補足日時：2014/01/05 01:37

No.2 回答者： kagakusuki 回答日時： 2014/01/04 14:43

>機器Bの１回目、E9セルには１月１日と、E10セルには空白が帰って来ています。

>また機器Aの２回目も同じ場所、C13セルが１月２日と、C14セルが空白で帰って来ています。

　それらは全て、前回の御質問、
http://oshiete.goo.ne.jp/qa/8405162.html
とは、条件が異なっている事が原因です。
　前回の御質問で質問者様が提示された例おいては、U列には日付と工場名しか入力されておりませんでしたが、今回の御質問では日付の下に1とか2といった数値が入力されています。
　前回の御質問に対して回答させて頂いた際に、私は

>　そして、8行1組のデータの中で、U列に日付や時間、数値のデータが入力されているのは１箇所のみであり、機器名として数値データとして扱う事が出来る様な名称は存在していないと考えても宜しいでしょうか？
>　もし、上記の条件が満たされている場合には、下記の様な方法を使う事が出来ます。

と述べた筈で、それに関しては質問者様からは何の御返答も御座いませんでしたので、御質問者様が取り組んでおられる状況においては、上記の様な条件から外れている訳ではないものとして回答させて頂いた次第なのですが、その後で状況が変わったという事なのですね？
　それでしたら、C9セルとC10セルに関数を入力する際に、その関数を次の様なものに変更されると良いと思います。


【C9セルに入力する関数】

=IF(INDEX($4:$4,COLUMN()-1)="","",IF(OR(IF(ISNUMBER(B9),OR(INT(B9)<B9,B9<1),FALSE),ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN()-1))),"",IF(INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)-B9+1)="","",INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)-B9+1))))


【C10セルに入力する関数】

=IF(INDEX($4:$4,COLUMN()-1)="","",IF(OR(IF(ISNUMBER(B9),OR(INT(B9)<B9,B9<1),FALSE),ROUNDUP((ROW()-ROW($A$8))/4,0)>COUNTIF($Y:$Y,INDEX($4:$4,COLUMN()-1))),"",IF(INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)-B9+4)="","",INDEX($U:$U,MATCH(INDEX($4:$4,COLUMN()-1)&"■"&ROUNDUP((ROW()-ROW($A$8))/4,0),$S:$S,0)-B9+4))))


　尚、上記の２つの関数は、V列には各「一括りになったデータ」毎に1から始まる連番が振られていて、尚且つ、その連番のデータがB9セルに表示されている事を前提としております。
　どの様な問題に関しても同様なのですが、状況が変わって前提条件から外れてしまいますと、それまでの手法は通用しなくなります。
　ですから、質問をされる際には、状況を正確に御伝え頂く様御願い致します。

No.1 回答者： ki-aaa 回答日時： 2014/01/04 10:28

VBAでの方法です。

　興味なかったらスルーしてください。

'興味があれば、"VBA 実行方法"　で検索してください。
'標準モジュールに貼り付けて実行してください。

Sub 配置換え()
Dim i As Long, j As Long, k As Long
Dim MaxRow As Long

Dim 機器名列 As Long, 試行回数 As Long, 関連データ行 As Long
Dim 機器名 As String
Dim myRange As Range, FindCell As Range


With Sheets("Sheet3") '実際のシート名にする

MaxRow = .Cells(Rows.Count, "Y").End(xlUp).Row 'Y列で最終行取得
.Range(.Cells(9, "B"), .Cells(48, "Q")).ClearContents


For 機器名列 = 2 To 16 Step 2 '16・機器名が左詰で最大8種ある
機器名 = .Cells(4, 機器名列).Value
If 機器名 = "" Then Exit Sub

'関連データの機器名列をmyRangeにセット
Set myRange = .Range(.Cells(1, "Y"), .Cells(MaxRow, "Y"))


For 試行回数 = 1 To 10
Set FindCell = myRange.Find(What:=機器名, After:=.Cells(MaxRow, "Y"), LookIn:=xlValue, LookAt:=xlWhole)
If FindCell Is Nothing Then Exit For
関連データ行 = FindCell.Row

.Cells(試行回数 * 4 + 5, 機器名列).Value = .Cells(関連データ行, "V").Value
.Cells(試行回数 * 4 + 6, 機器名列).Value = .Cells(関連データ行, "Z").Value
.Cells(試行回数 * 4 + 7, 機器名列).Value = .Cells(関連データ行, "AA").Value
.Cells(試行回数 * 4 + 8, 機器名列).Value = .Cells(関連データ行, "AC").Value

i = Int((関連データ行 - 1) / 8) * 8 '関連データデータグループ最初の行を求める
.Cells(試行回数 * 4 + 5, 機器名列 + 1).Value = .Cells(i + 1, "U").Value
.Cells(試行回数 * 4 + 6, 機器名列 + 1).Value = .Cells(i + 4, "U").Value
.Cells(試行回数 * 4 + 7, 機器名列 + 1).Value = .Cells(関連データ行, "AB").Value
.Cells(試行回数 * 4 + 8, 機器名列 + 1).Value = .Cells(関連データ行, "AD").Value

If 関連データ行 + 1 > MaxRow Then Exit For
Set myRange = .Range(.Cells(関連データ行 + 1, "Y"), .Cells(MaxRow, "Y"))
Next 試行回数


Next 機器名列
End With
End Sub

この回答への補足

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

えっ・・・・と、VBAは全然わからないのですが、マクロの画面を開いてすべて貼り付け、シート名と記述の中のシート名を合わせて実行したのですが、何も起こりません。

導入時に他にやることがありますか？

補足日時：2014/01/04 13:48