空白でないセルの値だけを取得する

質問

下記のデータが入っている表があります

　　　　　あ　い　う　え　お
リンゴ　 ○　○　　　　　○
ミカン 　○　 ○　○
イチゴ 　　　○　　　　　○
バナナ　　 ○　 ○　　　
パイン 　○　○　　　○

別のセルに「あ」と入力すると、「あ」列の○の付いている果物名だけを取得して
別のセルに結果を表示させたくて
ExcelのVBAで作成したいのですが、お願いいたします。

回答No.2

tom04 · ベストアンサー

こんばんは！
関数でもできそうな感じですが、VBAをご希望のようなので・・・
一例です。

↓の画像のようにSheet1にデータがあり、Sheet2のA1セルに検索項目を入力するとします。

↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, j, k, L As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
j = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
L = ws2.Cells(Rows.Count, 1).End(xlUp).Row
If L > 2 Then
ws2.Range(Cells(3, 1), Cells(L, 1)).Clear
End If
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(ws1.Rows(1), ws2.Cells(1, 1)) = 0 Then
If MsgBox("データがありません。操作を中止しますか？", vbYesNo) = vbYes Then Exit Sub
ElseIf WorksheetFunction.CountIf(ws1.Rows(1), ws2.Cells(1, 1)) Then
k = WorksheetFunction.Match(ws2.Cells(1, 1), ws1.Rows(1), False)
If ws1.Cells(i, k) = "○" Then
ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws1.Cells(i, 1)
End If
End If
Next i
End Sub

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

お礼

まさに、求めていたものズバリです
ありがとうございました

回答No.4

某HN クロメート(Chromate)（@CoalTar）

勉強がてらマクロの記録でフィルタオプションの設定を利用してみました。
H1セルは入力規則のリストで選択できるようにしてあります。

シート見出しを右クリック - コードの表示
Private Sub Worksheet_Change(ByVal Target As Range)
　 If Target.Address = "$H$1" Then
　 　 Range("j:j").Clear
　 　 　 If Range("A1") = "" Then Exit Sub
　 　 Range("A1").Copy
　 　 Range("J1").Select
　 　 ActiveSheet.Paste

　 　 Range("A1").CurrentRegion.AdvancedFilter _
　 　 Action:=xlFilterCopy, _
　 　 CriteriaRange:=Range("H1:H2"), _
　 　 CopyToRange:=Range("J1"), Unique:=False
　 End If
End Sub

添付図参照

お礼

なるほど
よくわかりました
ありがとうございました

回答No.3

kybo

あくまで一例ですが、Ｉ2のセルに検索する文字、結果をＪ2以降に表示する例です。

Sub macro()
Dim R As Range, C As Range
Range("J:J").ClearContents
Set R = Range("B1:F1").Find(What:=Range("I2").Value, LookAt:=xlWhole)
If Not R Is Nothing Then
For Each C In R.Offset(1).Resize(5).SpecialCells(xlCellTypeConstants).Offset(, 1 - R.Column)
Range("J" & Rows.Count).End(xlUp).Offset(1).Value = C.Value
Next C
End If
End Sub

お礼

こ、これ
す、すごいです！！
ホントありがとうございました

回答No.1

rukuku

こんばんは

セルI2に条件を入力して「抽出」を押すとシート2に結果を出力するサンプルです
原理的なことを地で行っているようなプログラムです。

1.セルI2の値を見て、どの列を対象とするか判断する
2.対象の列を上から１つずつチェックし、空白でなければシート2にコピーする
という手順です。

Sub 抽出()
　'変数の定義
　Dim LineData As Long
　Dim LineResult As Long
　Dim LastRow As Long
　Dim LastColumn As Long
　Dim CheckedColumn As Long
　Dim TargetColumn As Long

　'準備
　ThisWorkbook.Activate
　Worksheets(1).Select
　Worksheets(2).Cells.Clear
　LastRow = [A65536].End(xlUp).Row '最終行の取得
　LastColumn = [IV1].End(xlToLeft).Column '最終列の取得

　'抽出条件が指定されていない場合には実行しない
　If [I2] = "" Then
　　MsgBox "抽出条件を指定してください"
　　Exit Sub
　End If

　'抽出条件の列の設定
　For CheckedColumn = 2 To LastColumn
　　If Cells(1, CheckedColumn) = [I2] Then
　　　TargetColumn = CheckedColumn
　　　Exit For
　　End If
　Next CheckedColumn
　If TargetColumn = 0 Then
　　MsgBox "対象となる列が見つかりません"
　　Exit Sub
　End If

　'該当する行の抽出
　For LineData = 2 To LastRow
　　If Cells(LineData, TargetColumn) <> "" Then
　　　LineResult = LineResult + 1
　　　Worksheets(2).Cells(LineResult, "A") = Worksheets(1).Cells(LineData, "A")
　　End If
　Next LineData
End Sub

お礼

非常にわかりやい説明ありがとうございました
これが基本なんですね
おかげで思っていたとおりの結果がでて嬉しく助かりました
もっとVBAを勉強したくなりました