特定の文字を含むセルのコピー

質問

こんにちは。マクロ初心者で、質問なのですが、
エクセルで、シート1の各セルにデータが入っているのですが、
この中から特定の文字を含むセルのみをシート2の同じ位置のセルにコピーしたいのですが、
マクロで実行する場合、どうすればよいでしょうか？

例：
ＡＢＣ123｜ＡＣＤ445｜ＡＡＤ556
ＨＪＫ774｜ＪＡＢＴ54｜ＤＦＲ548
ＸＳＦ748｜ＫＩ5557Ｓ｜47ＡＢＯ7

のようなシート1があって、マクロを実行すると
シート2に「ＡＢ」を含むセルのみコピーして

ＡＢＣ123｜　　　　　｜
　　　　　｜ＪＡＢＴ54｜
　　　　　｜　　　　　　｜47ＡＢＯ7

といった感じにしたいのですが、
特定の文字は、いつも同じ文字を含むセルを抜き出しています。

回答No.2

mu2011 · ベストアンサー

一例です。
特定文字の大小文字、全半角は区別せず抽出しています。
特定する場合はMatchcase（大小文字）、matchbyte（全半角）をTrueで
調整して下さい。

Sub Sample()
Set pos = Cells.Find(What:="AB", _
lookat:=xlPart, MatchCase:=False, matchbyte:=False)
If pos Is Nothing Then Exit Sub
Set pos1st = pos
Do
Sheets("sheet2").Cells(pos.Row, pos.Column) = pos
Set pos = Cells.FindNext(pos)
Loop Until pos.Address = pos1st.Address
End Sub

お礼

回答、ありがとうございます。
早いですね。一瞬だったんで最初、２回も実行してしまいました（笑）
大小文字、全半角も選べてありがたいです。
応用もできそうです。大切にします。
ありがとうございます。

回答No.5

mitarashi

#4です。検索文字を与えるところで、折角設定した定数を使っていませんでした

If Not (buf(i, j) Like ("*" & searchWord & "*")) Then buf(i, j) = Empty

に変更して下さい。失礼いたしました。

お礼

２つも教えていただきありがとうございます。
いろいろな方法があるのですね。勉強になります。
この変部分は、

Sub test2()
Dim targetRange As Range
Dim buf As Variant
Dim i As Long, j As Long
Const searchWord As String = "ＡＢ"

Set targetRange = Worksheets(1).Range("A1").CurrentRegion
buf = targetRange
For i = 1 To UBound(buf, 1)
For j = 1 To UBound(buf, 2)
If Not (buf(i, j) Like ("*" & searchWord & "*")) Then buf(i, j) = Empty
Next j
Next i
Worksheets(2).Range(targetRange.Address) = buf
End Sub

という風に変更ということですね。
わざわざご丁寧にありがとうございます。

回答No.4

mitarashi

#3です。もう一つ思いつきました。やっている事は#1に類似ですが、速いと思います。

Sub test2()
Dim targetRange As Range
Dim buf As Variant
Dim i As Long, j As Long
Const searchWord As String = "ＡＢ" '全角の例

Set targetRange = Worksheets(1).Range("A1").CurrentRegion
buf = targetRange
For i = 1 To UBound(buf, 1)
For j = 1 To UBound(buf, 2)
If Not (buf(i, j) Like "*ＡＢ*") Then buf(i, j) = Empty
Next j
Next i
Worksheets(2).Range(targetRange.Address) = buf
End Sub

回答No.3

mitarashi

一応マクロでやっています。全角と半角は区別しますので、ご注意下さい。
Sub test()
Dim targetRange As Range
Const searchWord As String = "ＡＢ" '全角の例

Set targetRange = Worksheets(1).Range("A1").CurrentRegion
With Worksheets(2)
.Range(targetRange.Address).FormulaR1C1 = "=IF(ISERROR(FIND(""" & searchWord & """," & Worksheets(1).Name & "!RC)),""""," & Worksheets(1).Name & "!RC)"
.Range(targetRange.Address).Value = .Range(targetRange.Address).Value
End With
End Sub

回答No.1

xls88

試してください。

（全角限定の例）
Dim c As Range
For Each c In Sheets("Sheet1").Range("A1:C3")
If c.value Like "*ＡＢ*" Then　'★1
c.Copy Sheets("Sheet2").Range(c.Address)　'★2
End If
Next

（半角全角共コピーする例）
★1の処を下記に変えてください。
If StrConv(c.value, vbNarrow) Like "*AB*" Then

★2の処は下記でも大丈夫です。
Sheets("Sheet2").Range(c.Address).value = c.value

お礼

早速の回答ありがとうございます。
無事にデータの写しかえを行なうことが出来ました。
ありがとうございます。