[[20190221225908]]　『特定の単語のセルを隣にコピー』（ブルー☆）　ページの最後に飛ぶ

『特定の単語のセルを隣にコピー』（ブルー☆）

はじめまして
例えば　リンク先という単語が入ったセルを右隣にコピーするにはどうすればよろしいでしょうか
Like文を使うのはわかりますが

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 VBAでいいんですよね？
 こんな感じです。

 Sub test()
    Dim Rng As Range
    Set Rng = Range("A1")
    If InStr(Rng.Value, "リンク先") Then Rng.Copy Rng.Offset(, 1)
 End Sub
（ろっくん） 2019/02/22(金) 08:43

ありがとうございます
でも
Set Rng = Range("A1")
となってますがこれってシート全体を検索できるのでしょうか
（ブルー☆） 2019/02/22(金) 15:39

 検索ってどこにも書かれてなかったので、検索するコードは書いていません。
 A１セルに対してだけの例示です。

 検索する必要があるのであれば、対象となる範囲（ブックやシート、セル範囲など）
 教えていただけますか？
（ろっくん） 2019/02/22(金) 15:51

セルがシート全体なのかどうかは指定されてなかったし、該当セルが1シート内に複数あるかも指定されていないですよ。条件は全て挙げてもらえば、2度手間になりません。

とりあえず、該当セルが複数でも良いようにした例なぞ。

 Sub test()
    Dim R As Range

    For Each R In Cells.SpecialCells(xlCellTypeConstants)
        If R.Value Like "*リンク先*" Then
            R.Offset(0, 1).Value = Replace(R.Value, "リンク先", "リンク|")
        End If
    Next R
    Cells.Replace What:="リンク|", Replacement:="リンク先"
 End Sub
（???） 2019/02/22(金) 15:58

Like演算子を使うって言ってるので、「リンク先」という単語を"含む"セルが処理対象ですよね。
とりあえず、For Each～Next ステートメントを使って対象セルを探しておいてから処理する例です。

    Sub さんぷる1()
        Dim MyRNG As Range
        Dim 該当セル As Range

        Stop '←ブレークポイントの代わり

        For Each MyRNG In ActiveSheet.Range("A1:Z100")

            '▼リンク先が含まれるセルを覚えておく
            If MyRNG.Value Like "*リンク先*" Then
                If 該当セル Is Nothing Then
                    Set 該当セル = MyRNG
                Else
                    Set 該当セル = Union(該当セル, MyRNG)
                End If
            End If
        Next MyRNG

        '▼もし、リンク先が含まれているとして覚えたセルがあれば、１つ右へコピペする
        If Not 該当セル Is Nothing Then
            For Each MyRNG In 該当セル
                MyRNG.Copy MyRNG.Offset(, 1)
            Next MyRNG
        End If

    End Sub

 ※ただ、コピー先にすでになにかあっても上書きするのはもちろんのこと、「リンク先」
   という単語が含まれていた場合でもお構いなしなので
    A2に「あああリンク先ですよ」
    B2に「リンク先かも」
   と入っていた場合、B2からC2セルへのコピペはA2セルの内容で上書きされたあとの
   処理になりますから、それではまずいということであれば、別の手を考えないとダメですね。
　そもそも複数列を処理する話なのか質問からは判断できなかったので、対象列は１列しかない
  とかであれば心配無用でしょうが・・・

（もこな２） 2019/02/22(金) 16:04

コピー先が更にコピー対象になりそうに思ったのですが、以下で問題ないようです。

 Sub test()
    Dim R As Range

    For Each R In Cells.SpecialCells(xlCellTypeConstants)
        If R.Value Like "*リンク先*" Then
            R.Offset(0, 1).Value = R.Value
        End If
        DoEvents
    Next R
 End Sub
（???） 2019/02/22(金) 16:06

 アクティブブックの全シートを対象とした場合で・・
 Sub test2()
    Dim Sh  As Worksheet
    Dim Rng As Range
    For Each Sh In Worksheets
        For Each Rng In Union(Sh.Cells.SpecialCells(xlCellTypeConstants), Sh.Cells.SpecialCells(xlCellTypeFormulas))
            If InStr(Rng.Value, "リンク先") > 0 Then Rng.Copy Rng.Offset(, 1)
        Next Rng
    Next Sh
 End Sub
（ろっくん） 2019/02/22(金) 16:35

皆さんありがとうございます検索と書いたつもりだったのですがすいません
列の件はa列を対象ということを想定してます
（ブルー☆） 2019/02/22(金) 17:47

列が1つだけであれば簡単ですね。
最初からLike演算子にたどり着いているし、皆さんの回答をヒントに自力で出来ちゃってるかもしれませんが、一応。

    Sub さんぷる2()
        Dim MyRNG As Range

        With ActiveSheet
            For Each MyRNG In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
                If MyRNG.Value Like "*リンク先*" Then
                    MyRNG.Copy MyRNG.Offset(, 1)
                End If
            Next MyRNG
        End With

    End Sub

（もこな２） 2019/02/23(土) 11:37

コメント返信：

[ 一覧(最新更新順) ]

[[20190221225908]] 『特定の単語のセルを隣にコピー』（ブルー☆） ページの最後に飛ぶ

[[20190221225908]]　『特定の単語のセルを隣にコピー』（ブルー☆）　ページの最後に飛ぶ