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

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

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

などの不満があったので作ったやつ。

機能概要

全角英数を1文字ずつ検索しては半角に変換して回るだけ。
（カタカナは半角にはしない。@や,などの記号も適用外）

コード

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 "０" To "９", "ａ" To "ｚ", "Ａ" To "Ｚ": 英数のみ全→半 = 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