マクロで全角を一括で半角に置換したいです

質問

マクロで下記の作業を行いたいのですがよくわかりません。
アドバイスお願いします。

■作業内容

『Excelでsheetにある全角の文字を一括で半角に置換したい』

※基本的に半角にできるもの（カナ・英数字・記号）は全て半角にしたいのですが、『～』だけは半角にしたくありません。

■画面のイメージ

・sheet1にはマクロを組み込んだボタン画面
・sheet2に全角のデータＡ
・sheet3にデータＡを半角にしたデータＡ’が返される

■作業イメージ

(1)sheet1のボタンをクリック
(2)sheet2のデータを半角にしてsheet3に返す
(3)『~』を『～』に置換し直す。

すみませんがよろしくお願いいたします。

回答No.2

merlionXX · ベストアンサー

(2)sheet2のデータを半角にしてsheet3に返す
→sheet2のデータをsheet3にコピペし、その後半角化できるものは半角化する。
(3)『~』を『～』に置換し直す。

というマクロです。

Sub test01()
Sheets("Sheet3").Cells.Clear
With Sheets("Sheet2")
If WorksheetFunction.CountA(.Cells) > 0 Then
.Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).Copy
Else
Exit Sub
End If
End With
With Sheets("Sheet3")
.Range("A1").PasteSpecial
Application.CutCopyMode = False
For Each c In .UsedRange
c.Value = StrConv(c.Value, vbNarrow)
Next
.Cells.Replace What:="~~", Replacement:="～", LookAt:=xlPart
End With
End Sub

お礼

ご回答ありがとうございます。

早速使わせていただきました。
イメージしたとおりの結果となり、大満足です。

どうもありがとうございました。
助かりました。

回答No.1

Wendy02

こんにちは。

>基本的に半角にできるもの（カナ・英数字・記号）

カナはカタカナだと思いますね。ひらがなも必要なら半角は可能です。

>(3)『~』を『～』に置換し直す。
良く分かりませんが、『～』を置換しなければよのでは？

'Option Explicit
Dim RegExp As Object
Private Sub CommandButton1_Click()
　　Dim c As Range
　　If WorksheetFunction.CountA(Worksheets("Sheet3").Cells) > 0 Then
　　　　If MsgBox("Sheet3に、文字が入っていますが、削除しますか？", vbQuestion + vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　Else
　　　　　　Worksheets("Sheet3").Cells.Clear
　　　　End If
　　End If
　　If WorksheetFunction.CountA(Worksheets("Sheet2").Cells) > 0 Then
　　　　Worksheets("Sheet2").UsedRange.Copy Worksheets("Sheet3").Cells(1, 1)
　　　　Application.ScreenUpdating = False
　　　　For Each c In Worksheets("Sheet3").UsedRange.Cells
　　　　　　If VarType(c.Value) = vbString Then
　　　　　　　　c.Value = OneByteWordChange(c.Value)
　　　　　　End If
　　　　Next c
　　End If
　　Application.ScreenUpdating = True
　　Set RegExp = Nothing
End Sub

Private Function OneByteWordChange(ByVal txt As String) As String
　　Dim rep As String
　　Dim buf As String
　　Dim Matches As Object
　　Dim Match As Object
　　If RegExp Is Nothing Then
　　　　Set RegExp = CreateObject("VBScript.RegExp")
　　End If
　　With RegExp
　　　　.Global = True
　　　　.IgnoreCase = False
　　　　.Pattern = "[\u30A1-\u30FA\uFF01-\uFF5D]+"
　　　　If .Test(txt) Then
　　　　　　buf = txt
　　　　　　Set Matches = .Execute(txt)
　　　　　　For Each Match In Matches
　　　　　　　　rep = StrConv(Match, vbKatakana + vbNarrow)
　　　　　　　　buf = Replace(buf, Match, rep, , , vbBinaryCompare)
　　　　　　Next
　　　　　　OneByteWordChange = buf
　　　　Else
　　　　　　OneByteWordChange = txt
　　　　End If
　　End With
End Function

お礼

ご連絡が遅くなってしまい申し訳ありません。

＞良く分かりませんが、『～』を置換しなければよのでは？

なるほど、無理に置換しなくてもいいですね。
ご回答ありがとうございました。
参考にさせていただきます。