NewBaseMacro(2025)
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【C01_Cvt】に変更する。
モジュール名：C01_Cvt
Option Explicit
'+++*******************************************************+++
' 指定シート・列・形式でデータを変換し、カンマ等で整形表示
' formatType: "number", "comma", "text", "date"
' colList: "2,5,7" のようにカンマ区切りで列番号指定
' IsCall: Trueなら画面更新制御なし、Falseなら制御あり
' Call FormatColumns(wsData), "2,5,7", "comma", False)
' Call FormatColumns(Sheets("DataSheet"), "2,5,7", "comma", False)
'+++*******************************************************+++
Sub FormatColumns(ByVal targetSheet As Worksheet, ByVal colList As String, _
ByVal formatType As String, Optional ByVal IsCall As Boolean = False)
Dim colArr() As String
Dim colNO As Long
Dim MaxRow As Long
Dim sttRow As Long
Dim endRow As Long
Dim maxNo As Long
Dim i As Long, j As Long, X As Long
Dim myArray1 As Variant, myArray2 As Variant
Const PROsName = "FormatColumns"
If IsCall = False Then Call StopUpdating
Call ClearAllFilters
maxNo = 25000
colArr = Split(colList, ",")
With targetSheet
For j = LBound(colArr) To UBound(colArr)
colNO = CLng(Trim(colArr(j)))
sttRow = .Cells(2, colNO).Row 'タイトル行の下から開始
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
endRow = 0
If (MaxRow - sttRow) < maxNo Then
X = 1
Else
X = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
End If
For X = 1 To X
If sttRow + maxNo > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
' 表示形式の設定
Select Case LCase(formatType)
Case "comma": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "#,##0"
Case "number": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "0"
Case "text": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"
Case "date": .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "yyyy/mm/dd"
End Select
' データ変換処理
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
Select Case LCase(formatType)
Case "comma", "number"
If IsNumeric(myArray1(i, 1)) Then
myArray2(i) = Val(myArray1(i, 1))
Else
myArray2(i) = myArray1(i, 1)
End If
Case Else
myArray2(i) = myArray1(i, 1)
End Select
Else
myArray2(i) = ""
End If
Next i
' 書き込み
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = _
WorksheetFunction.Transpose(myArray2)
Erase myArray1
Erase myArray2
sttRow = endRow + 1
Next X
Next j
End With
If IsCall = False Then Call Updating
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
End Sub
'+++*******************************************************+++
' 指定シート・列で7桁ゼロ埋め整形（数値かつ7桁以下のみ対象）
' colList: "2,5,7" のようにカンマ区切りで列番号指定
' IsCall: Trueなら画面更新制御なし、Falseなら制御あり
' Call FormatTo7DigitZero(Sheets("Data"), "3,6,9", False)
'+++*******************************************************+++
Sub FormatTo7DigitZero(ByVal targetSheet As Worksheet, ByVal colList As String, _
Optional ByVal IsCall As Boolean = False)
Dim colArr() As String
Dim colNO As Long
Dim MaxRow As Long, sttRow As Long, endRow As Long
Dim maxNo As Long: maxNo = 25000
Dim i As Long, j As Long, X As Long
Dim myArray1 As Variant, myArray2 As Variant
If IsCall = False Then Call StopUpdating
Call ClearAllFilters
colArr = Split(colList, ",")
With targetSheet
For j = LBound(colArr) To UBound(colArr)
colNO = CLng(Trim(colArr(j)))
sttRow = .Cells(2, colNO).Row
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
endRow = 0
If (MaxRow - sttRow) < maxNo Then
X = 1
Else
X = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
End If
For X = 1 To X
If sttRow + maxNo > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo
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 IsNumeric(myArray1(i, 1)) Then
If Len(CStr(myArray1(i, 1))) <= 7 Then
myArray2(i) = Format(myArray1(i, 1), "0000000")
Else
myArray2(i) = myArray1(i, 1)
End If
Else
myArray2(i) = myArray1(i, 1)
End If
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = _
WorksheetFunction.Transpose(myArray2)
Erase myArray1: Erase myArray2
sttRow = endRow + 1
Next X
Next j
End With
If IsCall = False Then Call Updating
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Windows(ThisWorkbook.Name).WindowState = xlMinimized
End If
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 指定シート・列を全角数字・全角ハイフン・全角アルファベット・カタカナに変換（文字列として保持）
' テーブル・通常フィルターを解除してから処理
' ※ Microsoft Scripting Runtime 参照設定が必要
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub FormatToZenkaku(ByVal targetSheet As Worksheet, ByVal colList As String, _
Optional ByVal startRow As Long = 2, Optional ByVal maxNo As Long = 25000)
Dim colArr() As String
Dim colNO As Long, sttRow As Long, endRow As Long, MaxRow As Long
Dim i As Long, X As Long
Dim myArray1 As Variant, myArray2 As Variant
Dim r As Range
Dim colStr As Variant
'=== 初期化処理 ===
Call StopUpdating
Call ClearAllFilters
colArr = Split(colList, ",") 'カンマ区切りで複数列対応
For Each colStr In colArr
colNO = CLng(Trim(colStr))
sttRow = startRow
With targetSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
If (MaxRow - sttRow) < maxNo Then
X = 1
Else
X = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
End If
For X = 1 To X
If sttRow + maxNo > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo
End If
'=== 対象範囲の取得と書式設定 ===
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"
'=== 変換処理 ===
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) = ToZenkakuNumHyphenAlphaKana(CStr(myArray1(i, 1)))
Else
myArray2(i) = ""
End If
Next i
'=== 結果の書き込み ===
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = WorksheetFunction.Transpose(myArray2)
Erase myArray1: Erase myArray2
sttRow = endRow + 1
Next X
End With
Next colStr
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
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 指定シート・列を「カタカナのみ全角、他は半角」に変換（文字列として保持）
' テーブル・通常フィルターを解除してから処理
' ※ Microsoft Scripting Runtime 参照設定が必要
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub FormatToKatakanaZenkakuOnly(ByVal targetSheet As Worksheet, ByVal colList As String, _
Optional ByVal startRow As Long = 2, Optional ByVal maxNo As Long = 25000)
Dim colArr() As String
Dim colNO As Long, sttRow As Long, endRow As Long, MaxRow As Long
Dim i As Long, X As Long
Dim myArray1 As Variant, myArray2 As Variant
Dim colStr As Variant
Call StopUpdating
Call ClearAllFilters
colArr = Split(colList, ",")
For Each colStr In colArr
colNO = CLng(Trim(colStr))
sttRow = startRow
With targetSheet
MaxRow = .Cells(.Rows.Count, colNO).End(xlUp).Row
If (MaxRow - sttRow) < maxNo Then
X = 1
Else
X = Application.WorksheetFunction.RoundUp((MaxRow - sttRow) / maxNo, 0)
End If
For X = 1 To X
If sttRow + maxNo > MaxRow Then
endRow = MaxRow
Else
endRow = sttRow + maxNo
End If
myArray1 = .Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value
ReDim myArray2(LBound(myArray1, 1) To UBound(myArray1, 1))
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).NumberFormatLocal = "@"
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) = ToKatakanaZenkakuOnly(CStr(myArray1(i, 1)))
Else
myArray2(i) = ""
End If
Next i
.Range(.Cells(sttRow, colNO), .Cells(endRow, colNO)).Value = WorksheetFunction.Transpose(myArray2)
Erase myArray1: Erase myArray2
sttRow = endRow + 1
Next X
End With
Next colStr
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 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)
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 & ToHankaku(c) ' カタカナ以外は半角に変換
End If
i = i + 1
Loop
ToKatakanaZenkakuOnly = result
End Function
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
.Charset = "shift_jis"
.Position = 0
.Type = 1
.Charset = "utf-8"
ToHankaku = .ReadText
.Close
End With
End Function
コメント