エクセルVBAで質問です

質問

下のような表を作っています。
A列に日付がある限り、B、C、D、E列それぞれの列に対して、
3行目以降のデータが検索値と同じであれば、そのひとつ上の行の
値をG、H、I、J列にそれぞれ上から順に入れていきたいのですが、
どのようになるでしょうか。

A1 月日
B1 検索値1・・・B3以降データ
C1 検索値2・・・C3以降データ
D1 検索値3・・・D3以降データ
E1 検索値4・・・E3以降データ

G2以降に検索値1で調べた値
H2以降に検索値2で調べた値
I2以降に検索値3で調べた値
J2以降に検索値4で調べた値

例えば、B1の検索値が1であり、B10に1があったとします。
この場合、ひとつ上のB9の値をG2に来るようにしたいのです。

説明下手ですが教えていただけないでしょうか。

回答No.6

end-u

>ためさせていただきました。
であれば、その結果どうだったのか、コメントが欲しいところですね。
#3のSub try()とどう違うのかちょっと『？』でしたが、検索結果が複数あるのですね。

>私なりにつくってみました。動作はするのです
...という事なので、それでいいと思いますよ。

何をもって『スマート』とするかはその人の考え方次第だと思います。
別に同じ事の繰り返しを記述していたとしても、
自分で書いたコードですから、可読性が良い事も『スマート』さの一つの要件になると思います。

でもまぁ、書いちゃったんで。
Sub try2()
　　Dim r　As Range '基準となるA列範囲
　　Dim ri As Range 'For Each Loop用Object
　　Dim i　As Long　'Loopカウンタ
　　Dim n　As Long　'値セット先
　　Dim x　　　　　 '検索値

　　With ActiveSheet
　　　　Set r = .Range("A3", .Range("A3").End(xlDown))
　　　　For i = 1 To 4
　　　　　　x = .Cells(1, i + 1).Value
　　　　　　n = .Cells(.Rows.Count, i + 6).End(xlUp).Row
　　　　　　For Each ri In r.Offset(, i)
　　　　　　　　If ri.Value = x Then
　　　　　　　　　　n = n + 1
　　　　　　　　　　.Cells(n, i + 6).Value = ri.Offset(-1).Value
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
　　Set r = Nothing
End Sub

データ量が多いなら、配列を使ったりして効率を良くしたり、
オートフィルタも使ったりできるかなとちょっと思ったんですが、
その辺りはスキルに合わせて習得していかれれば良いでしょう。

回答No.5

keirika

#4です。

このような感じで良いのでしょうか。

Sub test()

Call test1(2, Range("b1"))
Call test1(3, Range("c1"))
Call test1(4, Range("d1"))
Call test1(5, Range("e1"))

End Sub

Sub test1(j As Integer, r As Range)

Dim i As Integer

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, j).Value = r.Value Then

Range("J65536").End(xlUp).Offset(1) = Cells(i - 1, j)

End If
i = i + 1
Loop

End Sub

回答No.4

keirika

Sub Sample()

Dim Bretu As Range
Dim Cretu As Range
Dim Dretu As Range
Dim Eretu As Range

Range("g2:j2").Clear

If Range("a1") = "" Then
Exit Sub
End If

Set Bretu = Range(Cells(3, 2), Cells(3, 2).End(xlDown))
Set Cretu = Range(Cells(3, 3), Cells(3, 3).End(xlDown))
Set Dretu = Range(Cells(3, 4), Cells(3, 4).End(xlDown))
Set Eretu = Range(Cells(3, 5), Cells(3, 5).End(xlDown))

If Not IsError(Application.Match(Range("b1"), Bretu, 0)) Then
Range("g2") = Cells(Application.Match(Range("b1"), Bretu, 0) + 1, 2)
End If

If Not IsError(Application.Match(Range("c1"), Cretu, 0)) Then
Range("h2") = Cells(Application.Match(Range("c1"), Cretu, 0) + 1, 2)
End If

If Not IsError(Application.Match(Range("d1"), Dretu, 0)) Then
Range("i2") = Cells(Application.Match(Range("d1"), Dretu, 0) + 1, 2)
End If

If Not IsError(Application.Match(Range("e1"), Eretu, 0)) Then
Range("j2") = Cells(Application.Match(Range("e1"), Eretu, 0) + 1, 2)
End If

Set Bretu = Nothing
Set Cretu = Nothing
Set Dretu = Nothing
Set Eretu = Nothing

End Sub

でどうでしょうか

お礼

ありがとうございました。ためさせていただきました。
私なりにつくってみました。動作はするのですが、見ての通り、同じことをコピーしているにすぎません。私の説明不足ですが、動作としてはしたのような動きをしたいのです。これ、もっとスマートにできないでしょうか？
恐縮ですが、#3の方にも同じ内容でお礼を入れさせていただきます。
宜しくお願いします。

Sub test()
Dim i As Integer

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 2).Value = Range("B1").Value Then

Range("G65536").End(xlUp).Offset(1) = Cells(i - 1, 2)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 3).Value = Range("C1").Value Then

Range("H65536").End(xlUp).Offset(1) = Cells(i - 1, 3)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 4).Value = Range("D1").Value Then

Range("I65536").End(xlUp).Offset(1) = Cells(i - 1, 4)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 5).Value = Range("E1").Value Then

Range("J65536").End(xlUp).Offset(1) = Cells(i - 1, 5)

End If
i = i + 1
Loop

End Sub

回答No.3

end-u

>A列に日付がある限り
という意味がわかりません。
例えば、A3:A100までの範囲で日付がはいっていたら、
『3行目以降のデータ』の範囲が、B3:B100、C3:C100...と限定されるという意味で良いですか？

とりあえず推測modeで。B1:E1に検索値を入れたあとに下記マクロ実行です。
Sub try()
　　Dim s As String

　　With ActiveSheet
　　　　s = "B$3:B$" & .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　With .Cells(.Rows.Count, 7).End(xlUp).Offset(1).Resize(, 4)
　　　　　　.Formula = "=INDEX(" & s & ",MATCH(B$1," & s & ",0)-1)"
　　　　　　.Value = .Value
　　　　End With
　　End With
End Sub
やってる事はINDEX/MATCH関数です。検索値が無ければ#N/Aを返します。

お礼

ありがとうございました。ためさせていただきました。
私なりにつくってみました。動作はするのですが、見ての通り、同じことをコピーしているにすぎません。私の説明不足ですが、動作としてはしたのような動きをしたいのです。これ、もっとスマートにできないでしょうか？
恐縮ですが、#4の方にも同じ内容でお礼を入れさせていただきます。
宜しくお願いします。

Sub test()
Dim i As Integer

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 2).Value = Range("B1").Value Then

Range("G65536").End(xlUp).Offset(1) = Cells(i - 1, 2)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 3).Value = Range("C1").Value Then

Range("H65536").End(xlUp).Offset(1) = Cells(i - 1, 3)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 4).Value = Range("D1").Value Then

Range("I65536").End(xlUp).Offset(1) = Cells(i - 1, 4)

End If
i = i + 1
Loop

i = 3
Do Until Cells(i, 1) = ""
If Cells(i, 5).Value = Range("E1").Value Then

Range("J65536").End(xlUp).Offset(1) = Cells(i - 1, 5)

End If
i = i + 1
Loop

End Sub

回答No.2

ingenium

すみません、No.1です。

「=IF(B2=B$1,B1,0)」
の間違いです。2つ目のBの前に$があるとJ列までコピーしたときにおかしくなってしまいます。

お礼

こんばんは。関数でもできますね。
今回はVBAで知りたいと思っています。二回にわたりありがとうございました。

回答No.1

ingenium

質問の意図をちゃんと理解できていなかったら申し訳ないのですが・・・

G2に「=IF(B2=$B$1,B1,0)」を入力して、J列までと表の下のほうまでドラッグでコピーすればいいのではないでしょうか。