注意点として､
･場所の最後の半角英数字1文字か2文字の最後にまれにｽﾗｯｼｭがつくことがありますが､これは無視します｡

･半角､全角､大文字､小文字はすべて区別します｡

･書式ごとｺﾋﾟｰしていただきますよう､お願いいたします｡

･該当場所がないときには､失敗したｾﾙの背景が真っ黒になり､次の行に移ります｡

･場所ｼｰﾄの該当場所はA,D,G列､行数は60まであります｡(途中空白の場合あり)
これを列＝3､行＝60を初期値として､指定を変えられるようにしてくださると助かります｡指定内を実行します｡

vlookup関数使うと行けそうな気がしますが｡｡｡｡
部分一致とか条件いるんでしょうか｡

こんな感じのことでしょうか｡

Option Explicit

Sub 文字列を読み取ってｼｰﾄに貼り付ける()
 Dim srcWS As Worksheet
 Set srcWS = Worksheets("★")
 
 Dim dstWS As Worksheet
 Set dstWS = Worksheets("場所")

 Dim objDic As New Scripting.Dictionary '// ﾂｰﾙ ⇒ 参照設定 ⇒ Microsoft.Scriting.RunTime にﾁｪｯｸ

 Dim dc As Long
 Dim r As Range
 For dc = 1 To 8 Step 3
 For Each r In dstWS.Cells(1, dc).Resize(60, 1)
 If r.Value <> "" Then objDic(CStr(r.Value)) = r.Column
 Next
 Next
 
 Dim ky1 As String
 Dim ky2 As String
 Dim dr As Range
 For Each r In srcWS.Range("A2", srcWS.Cells(Rows.Count, "A").End(xlUp))
 If r.Value <> "" Then
 If Right(r.Value, 1) = "/" Then
 ky2 = Replace(Trim(Right(" " & r.Value, 3)), "/", "")
 Else
 ky2 = Trim(Right(" " & r.Value, 2))
 End If
 ky1 = Right(ky2, 1)
 
 If objDic.Exists(ky2) = True Then
 Set dr = dstWS.Columns(objDic(ky2)).Find(ky2, lookat:=xlWhole)
 ElseIf objDic.Exists(ky1) = True Then
 Set dr = dstWS.Columns(objDic(ky1)).Find(ky1, lookat:=xlWhole)
 Else
 Set dr = Nothing
 r.Interior.ColorIndex = 1
 End If
 If Not dr Is Nothing Then
 If dr.Offset(0, 1).Value = "" Then
 r.Copy Destination:=dr.Offset(0, 1)
 r.Offset(0, 10).Copy Destination:=dr.Offset(0, 2)
 Else
 Set dr = dr.Offset(1, 0)
 Do While dr.Value = "" And dr.Offset(0, 1).Value <> ""
 Set dr = dr.Offset(1, 0)
 Loop
 dr.Resize(1, 3).Insert xlDown
 r.Copy Destination:=dr.Offset(-1, 1).Resize(1, 2)
 r.Offset(0, 10).Copy Destination:=dr.Offset(-1, 2)
 End If
 End If
 End If
 Next
End Sub