’全角化--------------------------------

'指定範囲の文字列を全て全角化します。

'参考ＵＲＬ http://oshiete1.goo.ne.jp/qa1153932.html

'週報担当、新着担当にはメニューバーに

  'マクロを割り当てたボタンを作成してあげるとよいでしょう。

'ほぼ全てのリストは全て全角で、絵文字は削除する必要がある。

'

 On Error Resume Next

 Dim rngCell As Range

 Dim r As Range

'範囲指定

 Set r = Application.InputBox("文字を全角化します。" _

 & Chr(13) & Chr(13) & "全角化したい文字のあるセル（行、列）を範囲指定してください。", Type:=8)

 Application.ScreenUpdating = False

  For Each rngCell In r

  If rngCell.Value <> "" Then

  '全角化

  rngCell.Value = StrConv(rngCell.Value, vbWide)

  End If

  Next rngCell

 Application.ScreenUpdating = True

'***************************************************************************

Function myStrFmt(文字列 As String)--------------------------------

  Dim ReplaceList As String

  Dim TargetStr As String

  Dim MAK As String

  Dim EMOJI As String

  Dim i As Long

  '半角化の対象とする文字を全角で定義

  ReplaceList = "♪○●◎■□◆◇△▲▽▼☆★"

 

  '空白に置換

  For i = 1 To Len(ReplaceList)

  TargetStr = Mid(ReplaceList, i, 1)

  文字列 = Replace(文字列, TargetStr, "")

  Next i

  myStrFmt = 文字列

End Function

Sub 絵文字削除()

  On Error Resume Next

  Dim rngCell As Range

  Dim r As Range

'範囲指定

 Set r = Application.InputBox("iモード指定の絵文字250文字と、いくつかの記号を削除します。" _

 & Chr(13) & Chr(13) & "絵文字を削除したい文字のあるセル（行、列）を範囲指定してください。", Type:=8)

 

 

  Application.ScreenUpdating = False

  For Each rngCell In r

  If rngCell.Value <> "" Then

  rngCell.Value = myStrFmt(rngCell.Value)

  End If

  Next rngCell

  Application.ScreenUpdating = True

End Sub

***************************************************************