「今さら」なんてない

「自分にもできそう」を伝播させるブログ

ブック内の全角英数を半角に一括変換する【Excel VBA】

社内でいろんな人がいじるブックに
全半角が入り交じっており

  • 検索がかけられない
  • 転記マクロの検索対象に引っかからない

などの不満があったので作りました。
(というかそもそも英数を全角で入れる人なんなの)

機能

まあそのまんまですが
全角英数を1文字ずつ検索しては
半角に変換して回るだけです。

ただしカタカナは半角にはしませんし
@や,などの記号も適用外です。

あくまで英数のみをやっつけます。

説明

最後のセルの探索

いったん1000×100の範囲内に区切ったのですが、
これ以上必要な方は

Function LastCell() As range

の中の

Dim rLast: rLast = 1000 '1000行以内には収まるだろう
Dim cLast: cLast = 100 '100列以内には収まるだろう

をいじってください
(まあこれなら最終セル探索いらないかもだけど練習がてら)

カタカナ除外にひと手間

カタカナを含めてやれば
セルの中身まで入っていかなくてもよくて
簡単なのですが、

カタカナを避けてやろうとすると
1文字ずつ判別しながらやらないといけないので
ひと手間かかるのですが、
英数のみ適用とするように
条件分岐させてやればいいだけです。

Function 英数のみ全→半(strPart)
  Select Case strPart
    Case "0" To "9", "a" To "z", "A" To "Z": 英数のみ全→半 = StrConv(strPart, vbNarrow)
  Case Else
    英数のみ全→半 = strPart
  End Select
End Function

ただ,セル内に混在しているパターンがあるので
1文字ずつ区切って処理していく必要があります.

  For Each rg In Arr
    strAssm = ""
    For s = 1 To Len(rg)
      strPart = Mid(rg, s, 1)
      strPart = 英数のみ全→半(strPart)
      strAssm = strAssm + strPart
    Next s
    Arr(k) = strAssm
    k = k + 1
  Next rg

セル参照の回数は減らした方がいい

繰り返し処理の中で都度セルを参照していじると
繰り返し回数が少ない内は問題ないのですが、
数が増えるとクソ重くて最終的にフリーズします。

なので最初にまとめて配列に格納して、
配列内でいじって
最後にセルに戻した方がいいです。

コード

Option Explicit

Sub Main_ブック内の全角英数を半角に一括変換する()
  Debug.Print Time
  Application.ScreenUpdating = False

  Dim wb As Workbook: Set wb = ActiveWorkbook
  Dim ws As Worksheet
  Dim cnt As Long: cnt = wb.Sheets.Count
  
  Dim st As Long
  For st = 1 To cnt
    Set ws = Sheets(st)
    Call シート内全→半(ws)
  Next st
  
  Debug.Print Time
  Application.ScreenUpdating = True

End Sub

Sub シート内全→半(ws As Worksheet)
  Dim strAssm As String, strPart As String
  
  Dim rLast  As Long: rLast = LastCell.Row
  Dim cLast  As Long: cLast = LastCell.Column
  Dim Arr As Variant: Set Arr = ws.Cells(1, 1).Resize(rLast, cLast)
  Dim rg 
  Dim s As Long
  Dim k As Long: k = 1
  For Each rg In Arr
    strAssm = ""
    For s = 1 To Len(rg)
      strPart = Mid(rg, s, 1)
      strPart = 英数のみ全→半(strPart)
      strAssm = strAssm + strPart
    Next s
    Arr(k) = strAssm
    k = k + 1
  Next rg

  Cells(1, 1) = Arr

End Sub

Function 英数のみ全→半(strPart)
  Select Case strPart
    Case "0" To "9", "a" To "z", "A" To "Z": 英数のみ全→半 = StrConv(strPart, vbNarrow)
  Case Else
    英数のみ全→半 = strPart
  End Select
End Function

Function LastCell() As range
  Dim r As Long
  Dim rLast: rLast = 1000 '1000行以内には収まるだろう
  Do Until WorksheetFunction.CountA(Rows(rLast)) > 0
    rLast = rLast - 1
  Loop
  
  Dim cLast: cLast = 100 '100列以内には収まるだろう
  Do Until WorksheetFunction.CountA(Cells(rLast, cLast)) > 0
    cLast = cLast - 1
  Loop
  
  Set LastCell = Cells(rLast, cLast)
End Function

以上です。
何万行とかのいじめ検証はしていないので
不足があるかもしれませんが、
多くの会社で蔓延ってる問題じゃないかなと思うので
何かのお役立ていただければ幸いです。

これも個人用マクロブックとかで
隠し持っていたら便利かもしれません。