【エクセル・ＶＢＡコードの書き方】データの抽出

質問

１位 　　２位 　　　 ３位 　　　 ４位 　　　 ５位
Ａ 　
Ｂ 　 　　　　　25
Ｃ 　　　　　　　　　　　　　30 　　　　　　　　　　　18
Ｄ
Ｅ 　 11

ＶＢＡの初心者であります。

上のエクセルの表において、以下の作業を自動的に行なえるようなＶＢＡのコードを教えて頂けると有り難く思います。

まず表の説明からしますと、
Ａ～Ｅは人の名前を表しています。
１～５位は彼らの順位（ある競争）です。

数値が四つ（２５、３０、１８、１１）ありますが、
この四つの数値のなかで、２０以上のものだけが、別のシートに自動的に入力されるようにしたいです。
かつ、その２０以上の数値の位置（例えば２５であれば、Ｂ、２位）もそのシートに入力されるようにしたいのです。

例えば別のシートでは以下のようにデータを表したいです。

名前　　　　順位　　　　数値
　Ｂ　　　　　２位　　　　　２５
　Ｃ　　　　　３位　　　　　３０

感覚的にはif 文とLoop文を用いると思うのですが、、うまくコードが組めません。
そもそもこれらの作業をＶＢＡ（マクロ）に組むことができますでしょうか。

宜しくお願いいたします。

回答No.4

tom04

こんにちは！
すでに回答は出ていますので、参考程度で・・・

列は5位（F列）までしかない！という前提です。

Sheet1にデータがあり、Sheet2に表示するようにしてみました。

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

Sub test() 'この行から
Dim i, j As Long
Dim ws As Worksheet
Set ws = Worksheets("sheet2")
ws.Cells.ClearContents
With ws.Cells(1, 1)
.Value = "名前"
.Offset(, 1) = "順位"
.Offset(, 2) = "数値"
End With
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row '2行目～最終行まで
For j = 2 To 6 'B～F列まで
If Cells(i, j) >= 20 Then
With ws.Cells(Rows.Count, 3).End(xlUp).Offset(1)
.Value = Cells(i, j)
.Offset(, -1) = Cells(1, j)
.Offset(, -2) = Cells(i, 1)
End With
End If
Next j
Next i
End Sub 'この行まで

こんな感じではどうでしょうか？m(__)m

回答No.3

mu2011

>別のシートに自動的に入力されるようにしたいです

順位シートに数値入力後にSheet2へ自動反映していますので期待値と相違している場合は読み捨て下さい。
イベントプロシージャにつき、シートモジュールにしています。
順位シートタブ上で右クリック→コードの表示→サンプルコード貼り付け後、順位シートに数値入力してお試しください。

■サンプルコード
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:F6")) Is Nothing Then Exit Sub
If Target.Value >= 20 Then
With Sheets("sheet2")
i = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(i + 1, 1).Value = Cells(Target.Row, 1)
.Cells(i + 1, 2).Value = Cells(1, Target.Column)
.Cells(i + 1, 3).Value = Target.Value
End With
End If
End Sub

回答No.2

KURUMITO

次のコードにしてください。

Sub データ抽出転記()
Dim Row1 As Integer
Dim Coln1 As Integer
Dim Row2 As Integer
Dim Coln2 As Integer
Dim i As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Row2 = 1
Coln2 = 0
i = 0
For Row1 = 2 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For Coln1 = 2 To WS1.Cells(1, 2).End(xlToRight).Column
If WS1.Cells(Row1, Coln1) >= 20 And i = 0 Then
Row2 = Row2 + 1
WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1)
i = i + 1
End If
If WS1.Cells(Row1, Coln1) >= 20 And i = 1 Then
Coln2 = Coln2 + 2
WS2.Cells(Row2, Coln2 - 1) = WS1.Cells(1, Coln1)
WS2.Cells(Row2, Coln2) = WS1.Cells(Row1, Coln1)
End If
Next Coln1
Coln2 = 1
i = 0
Next Row1
End Sub

回答No.1

KURUMITO

シート１のA２セルから下方に名前が入力され、B１セルから右横のセルには１位、２位、・・と入力されているとします。
数値２０以上の該当セルのデータをシート２に表示させるとしてシート２のA１セルには名前、、B１セルには順位、C１セルには数値の文字列がそれぞれ入力されているとします。
なお、シート１の同じ氏名の行で２つ以上の２０以上のセルがある場合にはシート２では同じ氏名の行の右横にそれらのデータが追加されて表示されるようにします。
以下にはそのためのマクロを示します。参考にしてください。

Sub データ抽出転記()
Dim Row1 As Integer
Dim Coln1 As Integer
Dim Row2 As Integer
Dim Coln2 As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Row2 = 1
Coln2 = 0
For Row1 = 2 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
Row2 = Row2 + 1
WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1)
For Coln1 = 2 To WS1.Cells(1, 2).End(xlToRight).Column
If WS1.Cells(Row1, Coln1) >= 20 Then
Coln2 = Coln2 + 2
WS2.Cells(Row2, Coln2 - 1) = WS1.Cells(1, Coln1)
WS2.Cells(Row2, Coln2) = WS1.Cells(Row1, Coln1)
End If
Next Coln1
Coln2 = 1
Next Row1
End Sub