EXCELで英字を全角→半角にしたい。

質問

EXCEL2000を使用しています。

１．企業データが1万件入ったデータがあります。
２．企業名に含まれる英字を全角→半角にしたいのですが、できますでしょうか？
３．通常ですと=JIS(セル番地)で問題ないのですが、
カタカナや数字は全角のままで、英字だけ半角にしたいのです。

例）
ＮＴＴドコモ株式会社→NTTドコモ株式会社
ＳＯＮＹミュージック１２３株式会社→SONYミュージック１２３株式会社

ご回答の程、よろしくお願い致します。

回答No.2

salf · ベストアンサー

面白そうだったんで、似たような事例を元にやってみました。
中身としては、単純に「Ａ～Ｚ」を一文字づつ「A～Z」へ変更しているだけです。多分もっと早い方法はあるんだろうな～

Sub WEB用文字変換()

Dim SH As Worksheet

Application.ScreenUpdating = False
For Each SH In ActiveWorkbook.Sheets
Call ConvStrCase(SH.Name)
Next SH
Application.ScreenUpdating = True
MsgBox "Complete", vbInformation

End Sub

Private Sub ConvStrCase(strSheetName As String)

Dim Num As String
Dim Alb As String
Dim ConvTbl As String
Dim TargetArea As Range
Dim TargetChar As String

'半角化対象文字
ConvTbl = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ"
'置換範囲
Set TargetArea = Sheets(strSheetName).UsedRange
'置換
For i = 1 To Len(ConvTbl)
TargetChar = Mid$(ConvTbl, i, 1)
TargetArea.Replace _
What:=TargetChar, _
Replacement:=StrConv(TargetChar, vbNarrow), _
LookAt:=xlPart, _
MatchCase:=False
Next i
Set TargetArea = Nothing

End Sub

参考URL：

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1530399

お礼

早速にご回答いただき、どうもありがとうございました。
おかげさまで、概ねできました。
またよろしくお願いいたします。

補足

早速にご回答頂き、どうもありがとうございます。

１．問題なく全角→半角になり、コンプリートになりました。ありがとうございました。
２．一つお聞きしたいのですが、ワークシート全体を対象とするのではなく、範囲を指定することは出来ますでしょうか？
３．企業の住所やコンタクト情報等々、企業データが入っている為、Sheet1のB列に企業名が入っています。この部分を指定して、変換したいと思いますがいかがでしょうか？

お忙しいところ恐縮ですが、ご回答頂ければ幸いです。

よろしくお願い致します。

回答No.8

pankun

下記のサイトは参考になりますか？
自分は、EXCEL2000を持っていないので確認とれていません。
お試しください。

参考URL：

http://support.microsoft.com/default.aspx?scid=kb;ja;879878

お礼

早速にご回答いただき、どうもありがとうございました。
みなさまに、いろいろな情報をご提供いただき、感謝です。
おかげさまで、出来上がりました。
また、よろしくお願いいたします。

回答No.7

NCU

ん？
#6ですが、指定範囲内の英字のみ半角化したい場合は、#6のコードの

ActiveSheet.UsedRange を
　　↓
Selection に変更します。
（一ヵ所のみ）

お礼

早速にご回答いただき、どうもありがとうございました。
みなさまに、いろいろなVBAをご提供いただき、感謝です。
おかげさまで、出来上がりました。
また、よろしくお願いいたします。

回答No.6

NCU

高速に動作する（と思います。多分）
Sub 英字のみ半角化()
　　Application.ScreenUpdating = False
　　Dim a As Range, v() As Variant, r&, c&
　　For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues).Areas
　　　　With a
　　　　　　If .Count = 1 Then
　　　　　　　　ReDim v(1 To 1, 1 To 1)
　　　　　　　　v(1, 1) = .Value
　　　　　　Else
　　　　　　　　v = .Value
　　　　　　End If
　　　　　　For r& = 1 To UBound(v, 1)
　　　　　　　　For c& = 1 To UBound(v, 2)
　　　　　　　　　　v(r&, c&) = 半角$(v(r&, c&))
　　　　　　　　Next
　　　　　　Next
　　　　　　.Value = v
　　　　End With
　　Next
　　Application.ScreenUpdating = True
　　MsgBox "正常に終了しました。", , "英字のみ半角化"
End Sub

Private Function 半角$(ByVal s$)
　　Dim i%, c$
　　For i% = 1 To Len(s$)
　　　　c$ = Mid$(s$, i%, 1)
　　　　If c$ Like "[Ａ-Ｚａ-ｚ]" Then Mid(s$, i%, 1) = StrConv(c$, vbNarrow)
　　Next
　　半角$ = s$
End Function

回答No.5

KenKen_SP

こんにちは。KenKen_SP です。

処理の内容の割には仰々しく汚いソースですが、数万件のデータでも非常に
高速処理します。12万件のデータで5～7秒ぐらいです。
（WinXP 2.4GHz 512M Excel2002）

コード中の以下の部分を変更すると、文字種変換の内容をカスタマイズでき
ます。

1.　.Pattern = "([Ａ-ｚ]+)" '<---全角アルファベット
2.　vntParam = Replace(vntParam, M.Value, StrConv(M.Value, vbNarrow))

B列を選択して実行して下さい。

【以下ソースコード】

Option Explicit

Private mRegExp As Object

Public Sub ConvHalfChar_OnlyAlpha()

　　Dim rngArea　 As Range
　　Dim rngCols　 As Range
　　Dim rngTarget　　As Range

　　Const VAL_TYPE = xlTextValues Or xlNumbers
　　Const COUNT_MAX = 65536

　　' Selection の再定義
　　If Selection.Cells.Count > 1 Then
　　　　On Error Resume Next
　　　　Set rngTarget = Intersect(Selection, ActiveSheet.UsedRange)
　　　　Set rngTarget = rngTarget.SpecialCells(xlCellTypeConstants, VAL_TYPE)
　　　　If rngTarget Is Nothing Then Exit Sub
　　　　On Error GoTo 0
　　Else
　　　　Set rngTarget = Selection
　　End If

　　On Error GoTo ERROR_HANDLER
　　Application.ScreenUpdating = False

　　' 選択ブロック毎に一括処理
　　For Each rngArea In rngTarget.Areas
　　　　' メモリ不足にならない様にセル数が COUNT_MAX を超える
　　　　' 場合は、さらに分割処理
　　　　If rngArea.Cells.Count > COUNT_MAX Then
　　　　　　For Each rngCols In rngArea.Columns
　　　　　　　　Call sp_BLOCK(rngCols)
　　　　　　Next rngCols
　　　　Else
　　　　　　Call sp_BLOCK(rngArea)
　　　　End If
　　Next rngArea

TERMINATE:
　　On Error GoTo 0
　　Set rngTarget = Nothing
　　Set rngCols = Nothing
　　Set rngArea = Nothing
　　Set mRegExp = Nothing
　　Exit Sub

ERROR_HANDLER:
　　Application.ScreenUpdating = True
　　MsgBox "Error (" & Err.Number & ")" & vbLf _
　　　　　 & Err.Description, vbCritical
　　Resume TERMINATE

End Sub

' 選択ブロックごとの処理
Private Sub sp_BLOCK(ByRef rngrngTarget As Range)

　　If rngrngTarget.Cells.Count > 1 Then
　　　　Dim Buffer As Variant
　　　　Dim lngRow As Long, lngCol As Long
　　　　Dim i　　　As Long, j　　　As Long
　　　　With rngrngTarget
　　　　　　Buffer = .Value
　　　　　　lngRow = UBound(Buffer)
　　　　　　lngCol = UBound(Buffer, 2)
　　　　End With
　　　　' 値の加工
　　　　For i = 1 To lngRow: For j = 1 To lngCol
　　　　　　If Not IsEmpty(Buffer(i, j)) Then
　　　　　　　　Call sp_StrConv(Buffer(i, j))
　　　　　　End If
　　　　Next j: Next i
　　　　' 一括で書き込む
　　　　rngrngTarget.Value = Buffer
　　　　Erase Buffer
　　Else
　　　　Call sp_StrConv(rngrngTarget)
　　End If

End Sub

' 要素ごとの処理
Private Sub sp_StrConv(ByRef vntParam As Variant)

　　Dim MC　As Object ' MatchCollection
　　Dim M　 As Object ' Match

　　If mRegExp Is Nothing Then Set mRegExp = CreateObject("VBScript.RegExp")
　　With mRegExp
　　　　.Pattern = "([Ａ-ｚ]+)" '<---全角アルファベット
　　　　.IgnoreCase = False
　　　　.Global = True
　　　　Set MC = .Execute(vntParam)
　　End With
　　If Not MC Is Nothing Then
　　　　For Each M In MC
　　　　　　' 半角に変換
　　　　　　vntParam = Replace(vntParam, M.Value, StrConv(M.Value, vbNarrow))
　　　　Next M
　　End If
　　Set MC = Nothing: Set M = Nothing

End Sub

お礼

早速にご回答いただき、どうもありがとうございました。
みなさまに、いろいろなVBAをご提供いただき、感謝です。
おかげさまで、出来上がりました。
また、よろしくお願いいたします。

回答No.4

zap35

ASC関数に代わり、アルファベット文字のみを半角にする関数です。　=AASC(セル番地)　でご使用下さい

Function AASC(ByVal Target As Range) As String
Dim ptr As Integer, CnvChar As String, rng As Range
Const TblChar As String = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ" _
& "ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ"
If Target.Cells.Count > 1 Then
Set rng = Target.Cells(1, 1)
Else
Set rng = Target
End If
AASC = ""
If rng <> "" Then
AASC = rng
For ptr = 1 To Len(TblChar)
CnvChar = Mid(TblChar, ptr, 1)
AASC = Replace(AASC, CnvChar, StrConv(CnvChar, vbNarrow))
Next ptr
End If
End Function

お礼

早速にご回答いただき、どうもありがとうございました。
みなさまに、いろいろなVBAをご提供いただき、感謝です。
おかげさまで、出来上がりました。
また、よろしくお願いいたします。

回答No.3

merlionXX

> Sheet1のB列に企業名が入っています。この部分を指定して、変換したいと思いますがいかがでしょうか？

ではNo2さんのコードをお借りして・・・。

Sub ConvStrCase()
Dim ConvTbl As String
Dim TargetArea As Range
Dim TargetChar As String
Dim i As Integer

ConvTbl = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ" '半角化対象文字
Set TargetArea = Sheets("Sheet1").Columns(2) '置換範囲
For i = 1 To Len(ConvTbl) '置換
TargetChar = Mid$(ConvTbl, i, 1)
TargetArea.Replace _
What:=TargetChar, _
Replacement:=StrConv(TargetChar, vbNarrow), _
LookAt:=xlPart, _
MatchCase:=False
Next i
Set TargetArea = Nothing
End Sub

お礼

早速にご回答いただき、どうもありがとうございました。
みなさまに、いろいろなVBAをご提供いただき、感謝です。
おかげさまで、出来上がりました。
また、よろしくお願いいたします。

回答No.1

S-Fuji

関数では、一寸手に余りますね。
VBAを使えば出来ますが、プログラムを組む事が出来ないようでしたら、
置換を使って、A～Z迄、26回ほど順番に行う手も有ります。
データの量が多いので、その方が早いかも知れません。

ちなみに、=JISは、全角へ変換です、=ASCが半角変換です

お礼

早速にご回答いただき、どうもありがとうございました。
>ちなみに、=JISは、全角へ変換です、=ASCが半角変換です
そうでした。（苦笑）ありがとうございました。