仕事で困っています。

このようなマクロを組んでは如何でしょうか

Option Explicit

Sub 文字列取りだし()

'

' 文字列取りだし Macro

'

'

'取り出し対象

Dim varGet() As Variant

varGet = Range("B1:b6").Value

Dim strG As String

Dim strGet() As String

Dim lngY As Long

Dim lngYEnd As Long

lngY = LBound(varGet, 1)

lngYEnd = UBound(varGet, 1)

Do While lngY <= lngYEnd

ReDim Preserve strGet(lngY)

strG = varGet(lngY, 1)

strGet(lngY - 1) = Replace(strG, """", "")

lngY = lngY + 1

Loop

'抽出対象

Dim varChusyutu As Variant

varChusyutu = Range("c1:c6")

Dim strGet_C() As String

Dim lngY_C As Long

Dim lngYEnd_C As Long

lngY_C = LBound(varChusyutu, 1)

lngYEnd_C = UBound(varChusyutu, 1)

Do While lngY_C <= lngYEnd_C

ReDim Preserve strGet_C(lngY_C)

strGet_C(lngY_C - 1) = varChusyutu(lngY_C, 1)

lngY_C = lngY_C + 1

Loop

'抽出作業

Dim lngC_Chusyutu As Long

Dim lngC_Tango As Long

Dim strCCell As String

Dim strTCell As String

Dim lngFind As Long

Dim blnSearch As Boolean

Dim blnExist As Boolean

Dim strList() As String

ReDim strList(1)

lngC_Tango = 0

Do While lngC_Tango < 6

strTCell = strGet(lngC_Tango)

If Not Len(strTCell) = 0 Then

lngC_Chusyutu = 0

Do While lngC_Chusyutu < 6

strCCell = strGet_C(lngC_Chusyutu)

blnSearch = True

lngFind = 1

Do While blnSearch

lngFind = InStr(lngFind, strCCell, strTCell, vbTextCompare)

If Not lngFind = 0 Then

blnExist = F_HairetuKensaku(strList, strTCell)

If Not blnExist Then

ReDim Preserve strList(UBound(strList) + 1)

strList(UBound(strList) - 1) = strTCell

End If

lngFind = lngFind + Len(strTCell)

If lngFind > Len(strCCell) Then

Exit Do

End If

Else

blnSearch = False

End If

Loop

lngC_Chusyutu = lngC_Chusyutu + 1

Loop

End If

lngC_Tango = lngC_Tango + 1

Loop

'結果出力

Dim lngLen As Long

lngLen = UBound(strList)

Dim lngRowmm As Long

lngRowmm = 0

Const cOutStart As Long = 6

Dim strOutCell As String

Do While lngRowmm < lngLen

Cells(lngRowmm + cOutStart, 2).Value = strList(lngRowmm) 'B列７行目以降に出力

lngRowmm = lngRowmm + 1

Loop

MsgBox ("完了")

End Sub

Private Function F_HairetuKensaku(strList() As String, strFind As String) As Boolean

Dim blnFind As Boolean

blnFind = False

Dim lngN As Long

lngN = 0

Dim lngEnd As Long

lngEnd = UBound(strList)

Do While lngN < lngEnd

If strList(lngN) = strFind Then

blnFind = True

Exit Do

End If

lngN = lngN + 1

Loop

F_HairetuKensaku = blnFind

End Function

１番　taknt さんと同様の回答ですが：

（１）取り出したい文字列を、優先順にＣ列以降の弟２行に記入する

　　　例：アメリカ、アラスカの順の場合、セルＣ２に「アメリカ」、セルＤ２に「アラスカ」

（２）文字列の有無を判断する関数を、Ｃ列以降の弟３行に記述する

　　　例：セルＣ３に、「=IF(ISERROR(FIND(C2,B3,1)),"",C2)」

　　　　　セルＤ３に、「=IF(ISERROR(FIND(D2,B3,1)),"",D2)」

　　　　　（１）で記入した文字列があるときはその文字列を２行目から引用表示し、無い時は空白を表示します。

（３）Ａ列のセルに、文字列有無の結果（Ｃ列以降の３行目）を連結表示する

　　　例：セルＡ３に、「=C3&D3」

（４）他の行に関数をコピーする準備として、参照セルを絶対位置指定に変える

　　　例：セルＣ３を、「=IF(ISERROR(FIND($C$2,B3,1)),"",$C$2)」

　　　　　セルＤ３を、「=IF(ISERROR(FIND($D$2,B3,1)),"",$D$2)」

（５）セルをコピーして他の行のセルに貼り付ける

　　　例：セルＣ３をコピーして、Ｃ列の最終行（Ｂ列に文章が入っている最終の行）までを選択して貼り付ける

　　　　　セルＤ３をコピーして、Ｄ列の最終行（Ｂ列に文章が入っている最終の行）までを選択して貼り付ける

　　　　　セルＡ３をコピーして、Ａ列の最終行（Ｂ列に文章が入っている最終の行）までを選択して貼り付ける

注意点：

１．Ｂ列の文はそのままです

　　「移動」よりも「抽出」のイメージです

２．同じ文字列を２箇所から取り出す場合は関数を変える必要があります

　　例：文「アメリカにあるアラスカは、アメリカの中でも･･･」から

　　　　アメリカ、アラスカ、アメリカと取り出したい場合

　　　　（１）は上記と同様に、セルＥ２に「アメリカ」と記入

　　　　（２）はセルＥ３に、「=IF(ISERROR(FIND(E2,B3,xxx)),"",E2)」

　　　　　　　xxx は　FIND(C2,B3,1)+LEN(C2)

URLは参照サイトです

http://www.eurus.dti.ne.jp/~yoneyama/Excel/kansu/itiran.html