集計用列を挿入するマクロ
2022年06月21日
過去の記事「列集計マクロの改良」に書いた通り、
マクロをがんばって改良したけど、そのマクロがない環境で同じ集計をやることになってとっさに別の方法を発見。
集計に必要な情報を書いた列を追加すればいいじゃん。。。
UI設計は、列集計マクロと同様にmsgboxとInputboxを使って
数値の除去の有無と取得する文字数を設定。
ちなみに数値を除去する処理は、当初ワイルドカードを使っていたけど
配列の計算なので圧倒的にforループの方が速かった。
ワイルドカード
https://vbabeginner.net/extract-non-numeric-characters-from-strings/
セルを配列に格納して、計算してからセルに戻す処理。
便利なので使うようになったけど、セルが１つしかないと
変数が配列じゃなくなって型エラーが出る。。。（将来対応だな）
書式については、タイトル行の次のセルの書式に合わせた。
マクロの中であれこれでてしまうと、
どのように出したかが追えなくなるので、
集計用の列を追加する方法は可読性の面でも有利だな。
以下、ソース。ソーステキストは こちら。
マクロをがんばって改良したけど、そのマクロがない環境で同じ集計をやることになってとっさに別の方法を発見。
集計に必要な情報を書いた列を追加すればいいじゃん。。。
UI設計は、列集計マクロと同様にmsgboxとInputboxを使って
数値の除去の有無と取得する文字数を設定。
ちなみに数値を除去する処理は、当初ワイルドカードを使っていたけど
配列の計算なので圧倒的にforループの方が速かった。
ワイルドカード
https://vbabeginner.net/extract-non-numeric-characters-from-strings/
セルを配列に格納して、計算してからセルに戻す処理。
便利なので使うようになったけど、セルが１つしかないと
変数が配列じゃなくなって型エラーが出る。。。（将来対応だな）
書式については、タイトル行の次のセルの書式に合わせた。
マクロの中であれこれでてしまうと、
どのように出したかが追えなくなるので、
集計用の列を追加する方法は可読性の面でも有利だな。
以下、ソース。ソーステキストは こちら。
Sub 集計用列を挿入()
Dim col As Long: col = Selection.Column
Dim strCol As String: strCol = getStrCol(col)
Dim tGyo As Long: tGyo = 1
If Cells(tGyo, col) = "" Then tGyo = Cells(tGyo, col).End(xlDown).Row
Dim edGyo As Long: edGyo = Cells(Rows.Count, col).End(xlUp).Row
Dim myRange As range: Set myRange = range(Cells(tGyo, col), Cells(edGyo, col))
Dim myArr: myArr = myRange.Value
Dim rc As Long: rc = MsgBox(strCol & "列の集計用列を追加します。数値を無視しますか？", vbYesNoCancel)
If rc = vbCancel Then End
Dim i As Long, n As Long, tStr As String
If rc = vbYes Then
For i = 1 To UBound(myArr)
For n = 0 To 9
myArr(i, 1) = Replace(myArr(i, 1), n, "")
Next n
Next i
tStr = "_rmNum"
End If
Dim inputMsg As String: inputMsg = "抽出文字数 Nを入力してください。" & Chr(10) & "+の場合：Left（N) -の場合：Right（N)"
Dim strLen: strLen = InputBox(inputMsg, "抽出文字数入力")
If strLen = "" Then strLen = 0
If IsNumeric(strLen) = False Then Call errorEnd("0以外の数値を入力してください")
If strLen > 0 Then
For i = 1 To UBound(myArr)
myArr(i, 1) = Left(myArr(i, 1), strLen)
Next i
tStr = tStr & "_Left" & strLen
ElseIf strLen < 0 Then
For i = 1 To UBound(myArr)
myArr(i, 1) = Right(myArr(i, 1), Abs(strLen))
Next i
tStr = tStr & "_right" & Abs(strLen)
End If
Selection.EntireColumn.Offset(0, 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
myRange.Offset(0, 1).NumberFormatLocal = Cells(tGyo + 1, col).NumberFormatLocal
myRange.Offset(0, 1).Value = myArr
Cells(tGyo, col + 1) = Cells(tGyo, col).Value & tStr
End Sub
Private Function getStrCol(ColNumber As Long) As String
'列番号を列文字に変換
getStrCol = Split(Cells(1, ColNumber).Address(True, False), "$")(0)
End Function
'エラー発生時にメッセージを出力して終了させる
Private Sub errorEnd(msg)
Application.ScreenUpdating = True 'おまじない
MsgBox msg
End
End Sub
PR
Comment