Excel VBAで特定の文字(記号)を含むセルのみを抽出し、それを別シートに表示したい

Question

前提・実現したいこと

Excel VBAを使用しています。
Sheet1には
![]
↑このような文字列がセルに入力されています。
このうち、文字列に『→』を含むセルのみを別ブックのSheet2に表示させたいです。
例えば上に貼付致しました画像の場合ですと、Sheet2に

↑このように一括表示させたいです。
「d→e」が入力してあるCells(1,2)は1行目の2列目、「j→k」が入力してあるCells(3,3)は3行目の3列目なのでこのような表示になります。

手順といたしましては
①行番号と列番号をそれぞれ(i,j)と置きRange("A1","C3")のセルを一括で取得
②「→」を含むセル番号をSheet2に一括表示

という流れになるのかな...と思いましたが、それをコードで表すことができず悩んでおります。
もしわかる方がいらっしゃいましたらアドバイスなどよろしくお願い致します。

発生している問題・エラーメッセージ

該当のソースコード

ExcelVBA

試したこと

補足情報（FW/ツールのバージョンなど）

Comments

[aki.aki.]

ＶＢＡのコードを書いたことがありますか？１行でもいいので、コードを書きましょう。場合によっては、時間に余裕のある方が、教えてくれるかも知れませんが、ここで教わるには無理があります。

Answer 1

やりたいことに対して手順をざっくりと捉えすぎていることが「コードで表すことができない」原因だと思います。
もう少し掘り下げたいところですね。

特に「一括で取得」「一括表示」というあたりに問題がありそうだと感じました。

必要な情報をごちゃっと渡せばこちらの都合のいい形で結果を返してくれる関数など、ほとんどの場合ありません。
ないから自分でコーディングするんですよね。

やりたいことをひとつひとつ積み上げて形にしていくのがコーディングです。

---

今回の場合、「一括処理」とイメージしている部分を「対象セルひとつひとつに、同じ処理を繰り返す」と考えてみてはどうでしょうか。

① Range("A1:C3")のセル範囲からセルを１つずつ取り出すループ処理
② 取り出したセルに「→」が含まれているか判定（InStr関数、IF文）
③-a 「→」が含まれている場合、対象セルの行番号と列番号を取得し、Sheet2の各セルに出力。(Sheet2の何行目に出力するのかも制御しないとですね。Range.End(xlUp)など。)
③-b 「→」が含まれていない場合、特に処理しない
④ ②～③を取り出すセルがなくなるまで繰り返す

こうなると、ひとつひとつのセルに対する処理ではそんなに難しいキーワードはでてこなくなるのではないでしょうか？

例えば①なら

For Each c In Sheet1.Range("A1:C3")     '←①
    Msgbox c.Row & "," & c.Column       '←③aのヒント
Next                                    '←④

でセル範囲からセルを1つずつ取り出すループ処理ができます

②はIf文とInstr関数を組み合わせれば取り出したセルの文字に「→」が含まれるかチェックできます。

他の方のアドバイスも参考に、まずは作ってみてください。

---

ちなみに、対象のセル範囲に対してFind関数で検索をする方法もあります。
この場合、検索結果が見つかれば１セルずつ返されるので、検索が見つかる限り繰り返し処理するループ処理を作ることになります。

こちらの方がループ回数は少なくなりますが、少し高度なコーディングになりますね。

今回は対象セル数も少ないので、まずはInstr関数での検索でいいと思います。
とりあえず手を動かしてがんばってみてください。

Comments

[aki.aki.]

さすがです！初心者の方にはこういう手ほどきが必要なんですよね。すじ道を理解できれば、加速度的に進歩すると思うのです。

私も勉強させて頂きました。ありがとうございます！

[odanngo_taifu]

分かりやすくご説明していただき、ありがとうございました！
まずは問題文から処理手順をしっかりと掘り下げることを怠らず、一つずつ取り組んでいこうと思います。

Answer 2

既に回答がありますが、一応odanngo_taifuさんのお勉強の為に別の方法を。
1.Cellsを使うと、列番号、行番号でセルにアクセスできます。
2.Selectionを使うと、アクティブシートのセレクトされたセルの集合を表します。
つまりどこを選択した状態でも、プログラムコードに依存しない作りが可能です。

Sub hogehoge()
    Dim intcol As Integer: intcol = 1
    Dim introw As Integer: introw = 1
    Dim cellpoint As Range
    For Each cellpoint In Selection
        If (InStr(cellpoint.Value, "→") <> 0) Then
            Worksheets(2).Cells(introw, intcol).Value = cellpoint.Row
            Worksheets(2).Cells(introw, intcol + 1).Value = cellpoint.Column
            introw = introw + 1
        End If
    Next cellpoint
    Range("A1").Select
End Sub

Comments

[jawa]

「検査の対象を"A1:C3"以外にしたい場合、この方法ならシート上で選択した範囲が検査の対象となりますよ」
ということですね。

出力座標指定に関しては、私も基準セルに対するOffsetよりCellsのほうが直感的でわかりやすいと思います。

[odanngo_taifu]

無事解決致しました。分かりやすく教えていただき、大変勉強になりました。
ありがとうございました！

Answer 3

For Each と、InStr と、Offset を使いました。

シート(Sheet2) の、見出しは１行目、行列値の書き込みが2行目からだとして
データ上書きの例と、データ追記の例を貼りましたので参考にしてみて下さい。

見出し行などの条件が変わると期待するセルに書き込んでくれません。
書き直してみて下さい。
データ追記の例で使った End(xlUP) は、キーボードの 「End」「↓」「↑」 です。

Dim Rng As Range
Dim r As Integer

For Each Rng In Sheets("Sheet1").Range("A1:C3")
    If InStr(Rng.Value, "→") > 0 Then
        With Sheets("Sheet2")
            .Range("A2").Offset(r).Value = Rng.Row
            .Range("B2").Offset(r).Value = Rng.Column
        End With
        r = r + 1
    End If
Next Rng

Dim Rng As Range
Dim r As Integer

r = Cells(Rows.Count, 1).End(xlUp).Row

For Each Rng In Sheets("Sheet1").Range("A1:C3")
    If InStr(Rng.Value, "→") > 0 Then
        With Sheets("Sheet2")
            .Range("A1").Offset(r).Value = Rng.Row
            .Range("B1").Offset(r).Value = Rng.Column
        End With
        r = r + 1
    End If
Next Rng

Comments

[odanngo_taifu]

無事解決致しました。一つ一つ文法の意味を確認することもでき、大変勉強になりました。
ありがとうございました！

Answer 4

Sub test()
    Const cMyKye As String = "*→*"
    Dim rngTable As Range
    Dim rngTarget As Range
    Dim c As Range
    Dim ixRow As Long
    
    ThisWorkbook.Worksheets("Sheet1").Copy
    
    Set rngTable = Workbooks(Workbooks.Count).Worksheets(1).Range("A1").CurrentRegion
    rngTable.Replace cMyKye, ""
    On Error Resume Next
    Set rngTarget = rngTable.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If rngTarget Is Nothing Then Exit Sub
    
    ixRow = 2
    With ThisWorkbook.Worksheets("Sheet2").Cells
        For Each c In rngTarget
            .Item(ixRow, 1).Value = c.Row
            .Item(ixRow, 2).Value = c.Column
            ixRow = ixRow + 1
        Next
    End With
    
    rngTable.Worksheet.Parent.Close False
End Sub

遊びで別案。
置換機能で空白にし、ジャンプ機能で検索するようにしてみました。
参考になれば。。。（セルを読む量を減らしてみたけど、速度的には不明。）

Comments

[odanngo_taifu]

教えていただきありがとうございます！
これから一つずつ調べて理解しようと思います...!