選択セルの列ごと データ型一括変換
（Microsoft365 64bit環境推奨）
New Base Macro Book をコピーしてモジュールを追加して使用します
- 【Alt】＋【F11】キーを押下し、VBE画面を出す。
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【D01_Cvt】に変更する。
モジュール名：D01_Cvt
Option Explicit
'+++*********************************************************+++
' アクティブセルの列を文字列に変換（そのまま保持）
' 数値も文字列として扱う（ゼロ埋めなし）
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_PlainText()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant 'Transpose代替用の2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更（先に変更しておく） ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
R.Value = Trim(CStr(cellval))
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理 ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
If IsError(myArray1(i, 1)) Then
myArray2(i) = myArray1(i, 1)
ElseIf myArray1(i, 1) <> "" Then
myArray2(i) = CStr(myArray1(i, 1))
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を文字列に強制変換（先頭ゼロ・E表記対策）
' 数値も文字列として扱う（’付きでExcel に文字列認識させる）
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_ForceText()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant 'Transpose代替用の2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更（先に変更しておく） ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
If IsNumeric(cellval) And Len(CStr(cellval)) >= 15 Then
R.Value = "'" & Format(cellval, 0)
Else
R.Value = "'" & Trim(CStr(cellval))
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理 ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
If IsNumeric(cellval) And Len(CStr(cellval)) >= 15 Then
myArray2(i) = "'" & Format(cellval, 0)
Else
myArray2(i) = "'" & Trim(CStr(cellval))
End If
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を数値に変換（文字列→数値）
' 数値以外はそのまま保持（空白・エラーも含む）
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToVal()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を数値（カンマなし）に変更 ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "0"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
If IsNumeric(cellval) Then
cellval = CDbl(CStr(cellval)) ' 厳密な数値変換（16桁まで安全）
R.Value = cellval
Else
R.Value = cellval
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理 ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval ' エラー値はそのまま
ElseIf cellval <> "" Then
If IsNumeric(cellval) Then
myArray2(i) = CDbl(CStr(cellval)) ' 厳密な数値変換（安全）
Else
myArray2(i) = cellval ' 数値でなければそのまま
End If
Else
myArray2(i) = "" ' 空白は空のまま
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を数値に変換し、カンマ区切りで表示
' 数値以外はそのまま保持（空白・エラーも含む）
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToVal_CommaFormatted()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 表示形式をカンマ付き数値に変更 ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "#,##0"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
If IsNumeric(cellval) Then
R.Value = CDbl(CStr(cellval)) ' 厳密な数値変換（16桁まで安全）
Else
R.Value = cellval
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理 ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval ' エラー値はそのまま
ElseIf cellval <> "" Then
If IsNumeric(cellval) Then
myArray2(i) = CDbl(CStr(cellval)) ' 厳密な数値変換（安全）
Else
myArray2(i) = cellval ' 数値でなければそのまま
End If
Else
myArray2(i) = "" ' 空白は空のまま
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を日付形式に変換（yyyy/m/d）
' 日付以外はそのまま保持
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToDateFormatted()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を日付形式に変更（先に変更しておく） ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "yyyy/m/d"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
If IsDate(cellval) Then
R.Value = Format(cellval, "yyyy/m/d")
Else
R.Value = cellval
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理（日付変換） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
If IsDate(cellval) Then
myArray2(i) = Format(cellval, "yyyy/m/d")
Else
myArray2(i) = cellval
End If
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' テーブルに変換（選択セルを起点に、周囲のデータを整える）
' テーブル名は「TBL_シート名」、既存テーブルは静かに削除
'+++*********************************************************+++
Sub CvtToTable()
'=== 変数宣言 ===
Dim ws As Worksheet
Dim tblRange As Range
Dim tblName As String
Dim MaxRow As Long, MaxCol As Long
Dim currentCell As Range
Dim rowNum As Long, colNum As Long
Dim tblCount As Long
'=== 前処理 ===
Call StopUpdating
Call ClearAllFilters
Set ws = ActiveSheet
Set currentCell = ActiveCell
rowNum = currentCell.Row
colNum = currentCell.Column
'=== 最終行・最終列を取得（選択セルを基準に） ===
MaxRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
MaxCol = ws.Cells(rowNum, ws.Columns.Count).End(xlToLeft).Column
'=== テーブル範囲を設定（選択セルから右下へ） ===
Set tblRange = ws.Range(currentCell, ws.Cells(MaxRow, MaxCol))
'=== テーブル名を「TBL_シート名」に設定 ===
tblName = "TBL_" & ws.Name
'=== このシートの既存テーブル数を取得して、枝番を付ける ===
tblCount = ws.ListObjects.Count
If tblCount = 0 Then
tblName = tblName
Else
tblName = tblName & "_" & (tblCount + 1)
End If
'=== テーブル作成 ===
With ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=tblRange, _
xlListObjectHasHeaders:=xlYes)
.Name = tblName
.TableStyle = "TableStyleMedium2"
'.TableStyle = "TableStyleLight9"
End With
'=== 完了メッセージ ===
MsgBox "テーブルに変換しました：" & tblRange.Address & vbCrLf & "テーブル名：" & tblName, _
vbInformation
'=== オブジェクト解放（静かな後片付け） ===
Set tblRange = Nothing
Set ws = Nothing
Set currentCell = Nothing
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を前後トリム（2回）で整える
' ※ タイトル行の下のセルを選択して実行する
' エラー値、大量データ対応Ver.
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub exeTrim()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) Then
If VarType(cellval) = vbString Then
R.Value = Trim(Trim(cellval))
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== データ整形処理（前後トリム2回） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf VarType(cellval) = vbString Then
myArray2(i) = Trim(Trim(cellval))
Else
myArray2(i) = cellval
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を前後トリム（2回）で整える
' ※ タイトル行の下のセルを選択して実行する
' エラー値、大量データ対応Ver.
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub exeTrimSpe()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And VarType(cellval) = vbString Then
cellval = Trim(cellval)
cellval = Replace(cellval, Chr(12288), "") ' 全角スペース
cellval = Replace(cellval, vbLf, "") ' 改行
cellval = Replace(cellval, vbTab, "") ' タブ
R.Value = Trim(cellval)
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== データ整形処理（前後トリム＋特殊文字除去） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf VarType(cellval) = vbString Then
cellval = Trim(cellval)
cellval = Replace(cellval, Chr(12288), "") ' 全角スペース
cellval = Replace(cellval, vbLf, "") ' 改行
cellval = Replace(cellval, vbTab, "") ' タブ
myArray2(i) = Trim(cellval)
Else
myArray2(i) = cellval
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を7桁ゼロ埋め（書式："0000000"）で整える
' ※ タイトル行の下のセルを選択して実行する
' 数値かつ7桁以下の値のみ対象
' エラー値、大量データ対応Ver.
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub exe0000000()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And IsNumeric(cellval) Then
If Len(CStr(cellval)) <= 7 Then
R.Value = Format(cellval, "0000000")
End If
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
'=== 処理対象の終了行を決定（最大 maxNo 行まで） ===
'※Rangeは両端を含むため、+maxNo だと maxNo+1 行になるため -1 で調整
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== データ整形処理（数値かつ7桁以下 → "0000000" 書式） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf IsNumeric(cellval) Then
If Len(CStr(cellval)) <= 7 Then
myArray2(i) = Format(cellval, "0000000")
Else
myArray2(i) = cellval
End If
Else
myArray2(i) = cellval
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブシートに連番（最大10万件）を振り、
' 余分な右側の列を静かに削除するマクロ
'+++*********************************************************+++
Sub exeNumbering()
'=== 変数宣言 ===
Dim i As Long
Dim lastRow As Long ' B列基準の最終行
Dim lastCol As Long ' 1行目基準の最終列
Dim startNo As Long ' 開始番号（柔軟に変更可能）
Dim arrNo() As Variant ' 連番格納配列
'=== 前処理 ===
Call StopUpdating
Call ClearAllFilters
With ActiveSheet
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
startNo = 0
'=== 連番配列の作成（1行目はタイトルなので2行目から） ===
ReDim arrNo(1 To lastRow - 1, 1 To 1)
For i = 1 To lastRow - 1
arrNo(i, 1) = startNo + i
Next i
'=== 連番の貼り付け ===
.Range("A1").Value = "NO"
.Range(.Cells(2, 1), .Cells(lastRow, 1)).Value = arrNo
'=== 右側の余分な列を静かに削除 ===
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lastCol < .Columns.Count Then
.Columns(lastCol + 1).Resize(, 100).Delete Shift:=xlToLeft
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' アクティブセルの列を全角に変換（数字・ハイフン・英字・カタカナ）
' その他の文字はそのまま保持
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_ZenkakuNumHyphenAlphaKana()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更 ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
R.Value = ToZenkakuNumHyphenAlphaKana(CStr(cellval))
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理（対象文字を全角化） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
myArray2(i) = ToZenkakuNumHyphenAlphaKana(CStr(cellval))
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' 半角の数字・英字・ハイフン・カタカナを全角に変換（文字列として保持）
' 濁点・半濁点にも対応（例：ｶﾞ → ガ、ﾊﾟ → パ）
' ※ Microsoft Scripting Runtime の参照設定が必要
'+++*********************************************************+++
Function ToZenkakuNumHyphenAlphaKana(str As String) As String
Dim i As Long
Dim result As String
Dim c As String, NextChar As String
Dim code As Long
Dim KanaMap As Dictionary, DakutenMap As Dictionary, HandakutenMap As Dictionary
'=== 辞書の初期化 ===
Set KanaMap = New Dictionary
Set DakutenMap = New Dictionary
Set HandakutenMap = New Dictionary
'=== 半角 → 全角カタカナ基本変換 ===
With KanaMap
.Add "ｱ", "ア": .Add "ｲ", "イ": .Add "ｳ", "ウ": .Add "ｴ", "エ": .Add "ｵ", "オ"
.Add "ｶ", "カ": .Add "ｷ", "キ": .Add "ｸ", "ク": .Add "ｹ", "ケ": .Add "ｺ", "コ"
.Add "ｻ", "サ": .Add "ｼ", "シ": .Add "ｽ", "ス": .Add "ｾ", "セ": .Add "ｿ", "ソ"
.Add "ﾀ", "タ": .Add "ﾁ", "チ": .Add "ﾂ", "ツ": .Add "ﾃ", "テ": .Add "ﾄ", "ト"
.Add "ﾅ", "ナ": .Add "ﾆ", "ニ": .Add "ﾇ", "ヌ": .Add "ﾈ", "ネ": .Add "ﾉ", "ノ"
.Add "ﾊ", "ハ": .Add "ﾋ", "ヒ": .Add "ﾌ", "フ": .Add "ﾍ", "ヘ": .Add "ﾎ", "ホ"
.Add "ﾏ", "マ": .Add "ﾐ", "ミ": .Add "ﾑ", "ム": .Add "ﾒ", "メ": .Add "ﾓ", "モ"
.Add "ﾔ", "ヤ": .Add "ﾕ", "ユ": .Add "ﾖ", "ヨ"
.Add "ﾗ", "ラ": .Add "ﾘ", "リ": .Add "ﾙ", "ル": .Add "ﾚ", "レ": .Add "ﾛ", "ロ"
.Add "ﾜ", "ワ": .Add "ｦ", "ヲ": .Add "ﾝ", "ン"
.Add "ｧ", "ァ": .Add "ｨ", "ィ": .Add "ｩ", "ゥ": .Add "ｪ", "ェ": .Add "ｫ", "ォ"
.Add "ｯ", "ッ": .Add "ｬ", "ャ": .Add "ｭ", "ュ": .Add "ｮ", "ョ"
.Add "｡", "。": .Add "｢", "「": .Add "｣", "」": .Add "､", "、": .Add "･", "・"
End With
'=== 濁点合成マップ（例: ｶﾞ → ガ）===
With DakutenMap
.Add "カ", "ガ": .Add "キ", "ギ": .Add "ク", "グ": .Add "ケ", "ゲ": .Add "コ", "ゴ"
.Add "サ", "ザ": .Add "シ", "ジ": .Add "ス", "ズ": .Add "セ", "ゼ": .Add "ソ", "ゾ"
.Add "タ", "ダ": .Add "チ", "ヂ": .Add "ツ", "ヅ": .Add "テ", "デ": .Add "ト", "ド"
.Add "ハ", "バ": .Add "ヒ", "ビ": .Add "フ", "ブ": .Add "ヘ", "ベ": .Add "ホ", "ボ"
.Add "ウ", "ヴ"
End With
'=== 半濁点合成マップ（例: ﾊﾟ → パ）===
With HandakutenMap
.Add "ハ", "パ": .Add "ヒ", "ピ": .Add "ﾌ", "プ": .Add "ヘ", "ペ": .Add "ホ", "ポ"
End With
'=== 変換処理本体 ===
result = ""
i = 1
Do While i <= Len(str)
c = Mid(str, i, 1)
code = AscW(c)
Select Case code
Case 48 To 57, 65 To 90, 97 To 122
result = result & ChrW(code + 65248) ' 半角英数字 → 全角
Case 45
result = result & ChrW(65293) ' 半角ハイフン → 全角
Case Else
If KanaMap.Exists(c) Then
If i < Len(str) Then
NextChar = Mid(str, i + 1, 1)
If NextChar = "ﾞ" And DakutenMap.Exists(KanaMap(c)) Then
result = result & DakutenMap(KanaMap(c))
i = i + 1
ElseIf NextChar = "ﾟ" And HandakutenMap.Exists(KanaMap(c)) Then
result = result & HandakutenMap(KanaMap(c))
i = i + 1
Else
result = result & KanaMap(c)
End If
Else
result = result & KanaMap(c)
End If
Else
result = result & c
End If
End Select
i = i + 1
Loop
ToZenkakuNumHyphenAlphaKana = result
End Function
'+++*********************************************************+++
' アクティブセルの列を全角に変換（数字・ハイフン・英字）
' その他の文字はそのまま保持
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_ZenkakuNumHyphenAlpha()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更 ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
R.Value = ToZenkakuNumHyphenAlpha(CStr(cellval))
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理（対象文字を全角化） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
myArray2(i) = ToZenkakuNumHyphenAlpha(CStr(cellval))
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' 数字とハイフン、アルファベットを全角に変換
'+++*********************************************************+++
Function ToZenkakuNumHyphenAlpha(str As String) As String
Dim i As Integer
Dim result As String
Dim c As String
Dim code As Integer
result = ""
For i = 1 To Len(str)
c = Mid(str, i, 1)
code = AscW(c)
Select Case code
Case 48 To 57 ' 半角数字 0-9
result = result & ChrW(code + 65248)
Case 65 To 90 ' 半角英大文字 A-Z
result = result & ChrW(code + 65248)
Case 97 To 122 ' 半角英小文字 a-z
result = result & ChrW(code + 65248)
Case 45 ' 半角ハイフン -
result = result & ChrW(65293) ' 全角ハイフン
Case Else
result = result & c ' その他はそのまま
End Select
Next i
ToZenkakuNumHyphenAlpha = result
End Function
'+++*********************************************************+++
' アクティブセルの列を全角に変換（数字・ハイフンのみ）
' その他の文字はそのまま保持
' テーブル・通常フィルターを解除してから処理
'+++*********************************************************+++
Sub CvtToStr_ZenkakuNumHyphen()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更 ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
R.Value = ToZenkakuNumHyphen(CStr(cellval))
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理（数字・ハイフンのみ全角化） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
myArray2(i) = ToZenkakuNumHyphen(CStr(cellval))
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' 数字とハイフンを全角に変換（その他はそのまま保持）
' 半角 → 全角変換：数字（0?9）、ハイフン（-）
'+++*********************************************************+++
Function ToZenkakuNumHyphen(str As String) As String
Dim i As Integer
Dim result As String
Dim c As String
result = ""
For i = 1 To Len(str)
c = Mid(str, i, 1)
Select Case c
Case "0" To "9"
result = result & ChrW(AscW(c) + 65248) ' 半角数字 → 全角数字（Unicode差分）
Case "-"
result = result & ChrW(65293) ' 半角ハイフン → 全角ハイフン（Unicode U+FF0D）
Case Else
result = result & c ' その他はそのまま保持
End Select
Next i
ToZenkakuNumHyphen = result
End Function
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' アクティブセルの列をカタカナのみ全角に変換、他は半角のまま保持
' テーブル・通常フィルターを解除してから処理
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub CvtToStr_KatakanaZenkakuOnly()
'=== 変数宣言 ===
Dim MaxRow As Long
Dim R As Range
Dim i As Long, x As Long
Dim loopMax As Long 'ループ最大回数
Dim colNO As Long
Dim cellval As Variant
Dim myArray1 As Variant, myArray2 As Variant
Dim tmpArr As Variant '貼り付け用2次元配列
Dim sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
'=== 画面更新停止・フィルター解除 ===
Call StopUpdating
Call ClearAllFilters
'=== アクティブセル情報取得 ===
Set R = ActiveCell
sttRow = R.Row
colNO = R.Column
With ActiveSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
'=== 書式を文字列に変更（先に変更しておく） ===
.Range(.Cells(sttRow, colNO), .Cells(MaxRow, colNO)).NumberFormatLocal = "@"
If MaxRow = sttRow Then
'=== 1セルだけの時は個別処理 ===
cellval = R.Value
If Not IsError(cellval) And CStr(cellval) <> "" Then
R.Value = ToKatakanaZenkakuOnly(CStr(cellval))
End If
Else
'=== 通常の複数セル処理 ===
If (MaxRow - sttRow) < maxNo Then
loopMax = 1
Else
loopMax = Application.WorksheetFunction.RoundUp((MaxRow - sttRow + 1) / maxNo, 0)
End If
'=== 分割処理ループ ===
For x = 1 To loopMax
If sttRow + maxNo - 1 > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo - 1
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
'=== 型変換処理（カタカナのみ全角変換） ===
For i = LBound(myArray1, 1) To UBound(myArray1, 1)
cellval = myArray1(i, 1)
If IsError(cellval) Then
myArray2(i) = cellval
ElseIf cellval <> "" Then
myArray2(i) = ToKatakanaZenkakuOnly(CStr(cellval))
Else
myArray2(i) = ""
End If
Next i
'=== 安全な縦方向配列に変換して貼り付け ===
ReDim tmpArr(LBound(myArray2) To UBound(myArray2), 1 To 1)
For i = LBound(myArray2) To UBound(myArray2)
tmpArr(i, 1) = myArray2(i)
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = tmpArr
Erase myArray1: Erase myArray2: Erase tmpArr
sttRow = endRow + 1
Next x
End If
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' カタカナのみ全角に変換（濁点・半濁点対応）、他は半角
' ※ Microsoft Scripting Runtime の参照設定が必要
'+++*********************************************************+++
Function ToKatakanaZenkakuOnly(str As String) As String
Dim i As Long
Dim result As String
Dim c As String, NextChar As String
Dim code As Long
Dim KanaMap As Dictionary, DakutenMap As Dictionary, HandakutenMap As Dictionary
'=== 辞書の初期化 ===
Set KanaMap = New Dictionary
Set DakutenMap = New Dictionary
Set HandakutenMap = New Dictionary
'=== 半角 → 全角カタカナ基本変換 ===
With KanaMap
.Add "ｱ", "ア": .Add "ｲ", "イ": .Add "ｳ", "ウ": .Add "ｴ", "エ": .Add "ｵ", "オ"
.Add "ｶ", "カ": .Add "ｷ", "キ": .Add "ｸ", "ク": .Add "ｹ", "ケ": .Add "ｺ", "コ"
.Add "ｻ", "サ": .Add "ｼ", "シ": .Add "ｽ", "ス": .Add "ｾ", "セ": .Add "ｿ", "ソ"
.Add "ﾀ", "タ": .Add "ﾁ", "チ": .Add "ﾂ", "ツ": .Add "ﾃ", "テ": .Add "ﾄ", "ト"
.Add "ﾅ", "ナ": .Add "ﾆ", "ニ": .Add "ﾇ", "ヌ": .Add "ﾈ", "ネ": .Add "ﾉ", "ノ"
.Add "ﾊ", "ハ": .Add "ﾋ", "ヒ": .Add "ﾌ", "フ": .Add "ﾍ", "ヘ": .Add "ﾎ", "ホ"
.Add "ﾏ", "マ": .Add "ﾐ", "ミ": .Add "ﾑ", "ム": .Add "ﾒ", "メ": .Add "ﾓ", "モ"
.Add "ﾔ", "ヤ": .Add "ﾕ", "ユ": .Add "ﾖ", "ヨ"
.Add "ﾗ", "ラ": .Add "ﾘ", "リ": .Add "ﾙ", "ル": .Add "ﾚ", "レ": .Add "ﾛ", "ロ"
.Add "ﾜ", "ワ": .Add "ｦ", "ヲ": .Add "ﾝ", "ン"
.Add "ｧ", "ァ": .Add "ｨ", "ィ": .Add "ｩ", "ゥ": .Add "ｪ", "ェ": .Add "ｫ", "ォ"
.Add "ｯ", "ッ": .Add "ｬ", "ャ": .Add "ｭ", "ュ": .Add "ｮ", "ョ"
.Add "｡", "。": .Add "｢", "「": .Add "｣", "」": .Add "､", "、": .Add "･", "・"
End With
'=== 濁点合成マップ（例: ｶﾞ → ガ）===
With DakutenMap
.Add "カ", "ガ": .Add "キ", "ギ": .Add "ク", "グ": .Add "ケ", "ゲ": .Add "コ", "ゴ"
.Add "サ", "ザ": .Add "シ", "ジ": .Add "ス", "ズ": .Add "セ", "ゼ": .Add "ソ", "ゾ"
.Add "タ", "ダ": .Add "チ", "ヂ": .Add "ツ", "ヅ": .Add "テ", "デ": .Add "ト", "ド"
.Add "ハ", "バ": .Add "ヒ", "ビ": .Add "フ", "ブ": .Add "ヘ", "ベ": .Add "ホ", "ボ"
.Add "ウ", "ヴ"
End With
'=== 半濁点合成マップ（例: ﾊﾟ → パ）===
With HandakutenMap
.Add "ハ", "パ": .Add "ヒ", "ピ": .Add "ﾌ", "プ": .Add "ヘ", "ペ": .Add "ホ", "ポ"
End With
'=== 変換処理本体 ===
result = ""
i = 1
Do While i <= Len(str)
c = Mid(str, i, 1)
code = AscW(c)
Select Case code
Case 48 To 57, 65 To 90, 97 To 122
result = result & c ' 半角英数字はそのまま保持
Case 45
result = result & c ' 半角ハイフンもそのまま保持
Case Else
If KanaMap.Exists(c) Then
If i < Len(str) Then
NextChar = Mid(str, i + 1, 1)
If NextChar = "ﾞ" And DakutenMap.Exists(KanaMap(c)) Then
result = result & DakutenMap(KanaMap(c))
i = i + 1
ElseIf NextChar = "ﾟ" And HandakutenMap.Exists(KanaMap(c)) Then
result = result & HandakutenMap(KanaMap(c))
i = i + 1
Else
result = result & KanaMap(c)
End If
Else
result = result & KanaMap(c)
End If
Else
result = result & c
End If
End Select
i = i + 1
Loop
ToKatakanaZenkakuOnly = result
End Function
'+++*********************************************************+++
' 全角文字を半角に変換（文字コード変換による整え）
' ADODB.Streamを使って UTF-8 → Shift_JIS → UTF-8 に変換
' ※Windows環境での半角化に有効
'+++*********************************************************+++
Function ToHankaku(str As String) As String
Dim obj As Object
Set obj = CreateObject("ADODB.Stream")
With obj
.Charset = "utf-8" ' 入力文字列の文字コード
.Open
.WriteText str ' 文字列を書き込み
.Position = 0
.Type = 2 ' Textモードで読み出し準備
.Charset = "shift_jis" ' Shift_JIS に変換（ここで半角化される）
.Position = 0
.Type = 1 ' Binaryモードに切り替え
.Charset = "utf-8" ' 再び UTF-8 に戻す
ToHankaku = .ReadText ' 結果を取得
.Close
End With
End Function
'+++*********************************************************+++
' 選択範囲列分の全角スペースを半角に統一
' 飛び飛びの選択には非対応（連続列のみ）
' 1行目からシートの最終行までを対象
' 配列処理で高速化
'+++*********************************************************+++
Sub CvtToHalfSpace()
'=== 変数宣言 ===
Dim sltRng As Range ' 選択範囲
Dim tgtRng As Range ' 対象範囲（1行目～最終行）
Dim sttCol As Long ' 開始列
Dim endCol As Long ' 終了列
Dim MaxRow As Long ' 最終行
Dim dataArray As Variant ' 元データ配列
Dim i As Long, j As Long ' ループ用変数
'=== 前処理 ===
Call StopUpdating
Call ClearAllFilters
With ActiveSheet
' 使用済み範囲の最終行を取得（UsedRangeが空の場合の保険付き）
MaxRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
If MaxRow < 1 Then MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' 選択範囲の列情報を取得（連続列のみ対応）
Set sltRng = Selection
If sltRng Is Nothing Then Exit Sub
If sltRng.Areas.Count > 1 Then
MsgBox "連続した列のみ選択してください。", vbExclamation
Exit Sub
End If
sttCol = sltRng.Column
endCol = sttCol + sltRng.Columns.Count - 1
' 対象範囲を設定（1行目～最終行、選択列）
Set tgtRng = .Range(.Cells(1, sttCol), .Cells(MaxRow, endCol))
' データを配列に格納
dataArray = tgtRng.Value
' 配列内の全角スペースを半角に置換
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If Not IsError(dataArray(i, j)) Then
If VarType(dataArray(i, j)) = vbString Then
If dataArray(i, j) <> "" Then
dataArray(i, j) = Replace(dataArray(i, j), ChrW(12288), " ")
End If
End If
End If
Next j
Next i
' 配列をシートに書き戻し
tgtRng.Value = dataArray
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
'+++*********************************************************+++
' 選択範囲列分の半角スペースを全角に統一
' 飛び飛びの選択には非対応（連続列のみ）
' 1行目からシートの最終行までを対象
' 配列処理で高速化
'+++*********************************************************+++
Sub CvtToFullSpace()
'=== 変数宣言 ===
Dim sltRng As Range ' 選択範囲
Dim tgtRng As Range ' 対象範囲（1行目～最終行）
Dim sttCol As Long ' 開始列
Dim endCol As Long ' 終了列
Dim MaxRow As Long ' 最終行
Dim dataArray As Variant ' 元データ配列
Dim i As Long, j As Long ' ループ用変数
'=== 前処理 ===
Call StopUpdating
Call ClearAllFilters
With ActiveSheet
' 使用済み範囲の最終行を取得（保険付き）
MaxRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
If MaxRow < 1 Then MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' 選択範囲の列情報を取得（連続列のみ対応）
Set sltRng = Selection
If sltRng Is Nothing Then Exit Sub
If sltRng.Areas.Count > 1 Then
MsgBox "連続した列のみ選択してください。", vbExclamation
Exit Sub
End If
sttCol = sltRng.Column
endCol = sttCol + sltRng.Columns.Count - 1
' 対象範囲を設定（1行目～最終行、選択列）
Set tgtRng = .Range(.Cells(1, sttCol), .Cells(MaxRow, endCol))
' データを配列に格納
dataArray = tgtRng.Value
' 配列内の半角スペースを全角に置換
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If Not IsError(dataArray(i, j)) Then
If VarType(dataArray(i, j)) = vbString Then
If dataArray(i, j) <> "" Then
dataArray(i, j) = Replace(dataArray(i, j), " ", ChrW(12288))
End If
End If
End If
Next j
Next i
' 配列をシートに書き戻し
tgtRng.Value = dataArray
End With
'=== 他ブックから呼び出された場合は最小化 ===
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
'=== 画面更新再開 ===
Call Updating
End Sub
コメント