今回はVBAでオートフィルの強化版みたいなのを作ってみましたので紹介します。
尚、本記事では「元に戻すを破壊しないVBAの書き方」も記載しています。
使用風景
きっかけ
稀に単一のセルに含まれた複数の数値を、合わせてカウントアップさせたい時がある。
ところが、オートフィルを使うとこんな風に右端の数値しかカウントアップしてくれない。
オートフィル |
---|
No.1はID:1000 |
No.1はID:1001 |
No.1はID:1002 |
No.1はID:1003 |
No.1はID:1004 |
No.1はID:1005 |
そこで、全ての数値をカウントアップするようなマクロを作成することにした。
自作マクロ |
---|
No.1はID:1000 |
No.2はID:1001 |
No.3はID:1002 |
No.4はID:1003 |
No.5はID:1004 |
No.6はID:1005 |
前提関数1(Split_Number_Other)
概要
本命のプログラムへ入る前に、数字とそれ以外の文字を分割して配列に変換する関数を作成した。
文字列処理で気合で再現することも出来るが、今回は正規表現を使ってみた。
ソースコード
'数字とそれ以外を分割する 'abc >> abc 'abc123 >> abc 123 'abc123def >> abc 123 def '123def >> 123 def '123def456 >> 123 def 456 'abc123def456 >> abc 123 def 456 Public Function Split_Number_Other(Expression As String) As String() Dim Ret() As String ReDim Ret(0 To Len(Expression)) Dim i As Long, j As Long Dim reg As Object: Set reg = CreateObject("VBScript.RegExp") With reg .Pattern = "[^\d]+|[\d]+" .IgnoreCase = False .Global = True j = -1 Dim Match As Object For Each Match In .Execute(Expression) j = j + 1 Ret(j) = Match.Value Next End With If j = -1 Then Ret = Split(vbNullString) Else ReDim Preserve Ret(0 To j) End If Split_Number_Other = Ret End Function
テストコード
'テストコード Sub Test_Split_Number_Other() Debug.Print Join(Split_Number_Other(""), ",") Debug.Print Join(Split_Number_Other("abc"), ",") Debug.Print Join(Split_Number_Other("123"), ",") Debug.Print Join(Split_Number_Other("abc123"), ",") Debug.Print Join(Split_Number_Other("abc123def"), ",") Debug.Print Join(Split_Number_Other("123def"), ",") Debug.Print Join(Split_Number_Other("123def456"), ",") Debug.Print Join(Split_Number_Other("abc123def456"), ",") End Sub
出力
abc 123 abc,123 abc,123,def 123,def 123,def,456 abc,123,def,456
プログラム1
概要
基本方針としては、オートフィルを実行した直後の選択範囲に対してマクロを追加実行することで、オートフィルの結果を強化するという感じで開発した。
第一弾は単純に選択範囲の先頭行を下方向へフィルする例。
2次元配列に1次元配列を代入してジャグ配列化しているので、慣れていない人は注意。
ソースコード
'先頭行のデータを選択範囲全体に対して下方向へフィル Sub AutoFillPlus1() Dim i As Long, j As Long, k As Long Dim sel As Range: Set sel = ActiveWindow.RangeSelection If sel.Rows.Count = 1 Then Exit Sub Dim Data As Variant: Data = sel.Value Dim Jags As Variant: ReDim Jags(1 To UBound(Data, 1), 1 To UBound(Data, 2)) '数字とそれ以外に分割した情報をJagsへ For i = 1 To UBound(Data, 1) For j = 1 To UBound(Data, 2) Jags(i, j) = Split_Number_Other(CStr(Data(i, j))) Next Next 'フィル For i = 2 To UBound(Data, 1) For j = 1 To UBound(Data, 2) '各セルの構造を見て数値なら先頭行の値+kで上書き For k = LBound(Jags(i, j)) To UBound(Jags(i, j)) If IsNumeric(Jags(i, j)(k)) Then Jags(i, j)(k) = "" & (Jags(1, j)(k) + i - 1) End If Next Data(i, j) = Join(Jags(i, j), "") Next Next sel.Value = Data End Sub
プログラム2
概要
さて、プログラム1でもルールに沿って使用すれば全く問題ない。簡易的なマクロならこれで完成形と言って良いだろう。
でも作ってからしばらくしたらルール=使い方なんて覚えていない。
そしてデータが破壊される恐れがあるようなマクロは、私なら怖くて使えない。
というわけで、範囲内のデータが先頭行と同じ仕様であることを検査した上で、全く問題無い場合のみデータを書き換えるようにしてみた。
不適切なデータが見つかった場合は、セルを黄色く塗りつぶすようにした。
尚、実務では末尾に文字を付け足す事があるため、後半部分はなにが増えようが許容するように設計している。
ソースコード
Sub AutoFillPlus2() Dim i As Long, j As Long, k As Long Dim sel As Range: Set sel = ActiveWindow.RangeSelection If sel.Rows.Count = 1 Then Exit Sub Dim Data As Variant: Data = sel.Value Dim Jags As Variant: ReDim Jags(1 To UBound(Data, 1), 1 To UBound(Data, 2)) Dim dErr As Boolean '数字とそれ以外に分割した情報をJagsへ For i = 1 To UBound(Data, 1) For j = 1 To UBound(Data, 2) Jags(i, j) = Split_Number_Other(CStr(Data(i, j))) Next Next '先頭のデータ構造と同じか確認してからフィル 'sel.Interior.ColorIndex = xlColorIndexNone '色を白に戻す For i = 2 To UBound(Data, 1) For j = 1 To UBound(Data, 2) dErr = False If UBound(Jags(i, j)) >= UBound(Jags(1, j)) Then '各セルの構造を見て数値なら先頭行の値+kで上書き '文字列なら先頭行と同一ならOKだが、不一致ならエラーとする For k = LBound(Jags(1, j)) To UBound(Jags(1, j)) If IsNumeric(Jags(i, j)(k)) Then Jags(i, j)(k) = "" & (Jags(1, j)(k) + i - 1) ElseIf Jags(i, j)(k) = Jags(1, j)(k) Then Else dErr = True End If Next Else dErr = True End If If dErr Then 'エラーセルに着色 sel.Cells(i, j).Interior.Color = vbYellow Else '出力用二次元配列へ格納 Data(i, j) = Join(Jags(i, j), "") End If Next Next sel.Value = Data End Sub
プログラム3
概要
さてさて、多くの人はプログラム2でこれ以上改善の余地は無いと考えるだろう。
でも私はまだ「マクロ」として認めない。
なぜなら「元に戻す」が破壊されるからだ。
私は、ユーザーの(細々とした)操作支援を目的としたマクロは、「元に戻す」を破壊してはならないと思っている。※一括でデータ集計や変換を行うVBAとは全く別物。
というわけで、第三弾。
- エラー箇所は塗りつぶしではなく、選択状態で警告を出しマクロ終了
- フィルの結果は破壊しない方法を採用
なお、本マクロはクリップボードを破壊するが、そこまで書くと長くなるので今回は省略した。
※文字列情報だけなら開始時にGetCBを、終了時にSetCBを実行すれば保持するのは難しくない。
その前に、前提として使用する関数が増えたので先に記載しておく。
前提関数2
'二次元配列をCSV等の文字列に変換する。 Public Function Join2(arr As Variant, Optional Delimiter1 As String = vbTab, Optional Delimiter2 As String = vbCrLf) As Variant Dim i As Long, j As Long Dim Arr1() As Variant Dim Arr2() As Variant ReDim Arr1(1 To UBound(arr, 1)) ReDim Arr2(1 To UBound(arr, 2)) For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) Arr2(j) = arr(i, j) Next Arr1(i) = Join(Arr2, Delimiter1) Next Join2 = Join(Arr1, Delimiter2) End Function 'クリップボードに文字列を格納 Public Sub SetCB(ByVal str As String) With CreateObject("Forms.TextBox.1") .MultiLine = True .Text = str .SelStart = 0 .SelLength = .TextLength .Copy End With End Sub 'クリップボードから文字列を取得 Public Sub GetCB(ByRef str As String) With CreateObject("Forms.TextBox.1") .MultiLine = True If .CanPaste = True Then .Paste str = .Text End With End Sub
前提関数3
#If VBA7 Then Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPtr #Else Declare Function GetActiveWindow Lib "user32" () As Long Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long #End If 'アクティブウィンドウがVBEかどうかの判定 Function ActiveWindowsIsVBE() As Boolean ActiveWindowsIsVBE = (GetActiveWindow() = FindWindow("wndclass_desked_gsk", vbNullString)) End Function
ソースコード
Sub AutoFillPlus3() Dim i As Long, j As Long, k As Long Dim sel As Range: Set sel = ActiveWindow.RangeSelection If sel.Rows.Count = 1 Then Exit Sub Dim Data As Variant: Data = sel.Value Dim Jags As Variant: ReDim Jags(1 To UBound(Data, 1), 1 To UBound(Data, 2)) Dim dErr As Boolean Dim rngErr As Range '数字とそれ以外に分割した情報をJagsへ For i = 1 To UBound(Data, 1) For j = 1 To UBound(Data, 2) Jags(i, j) = Split_Number_Other(CStr(Data(i, j))) Next Next '先頭のデータ構造と同じか確認してからフィル For i = 2 To UBound(Data, 1) For j = 1 To UBound(Data, 2) dErr = False If UBound(Jags(i, j)) >= UBound(Jags(1, j)) Then '各セルの構造を見て数値なら先頭行の値+kで上書き '文字列なら先頭行と同一ならOKだが、不一致ならエラーとする For k = LBound(Jags(1, j)) To UBound(Jags(1, j)) If IsNumeric(Jags(i, j)(k)) Then Jags(i, j)(k) = "" & (Jags(1, j)(k) + i - 1) ElseIf Jags(i, j)(k) = Jags(1, j)(k) Then Else dErr = True End If Next Else dErr = True End If If dErr Then 'エラーセルをストック If rngErr Is Nothing Then Set rngErr = sel.Cells(i, j) Else Set rngErr = Union(rngErr, sel.Cells(i, j)) End If Else '出力用二次元配列へ格納 Data(i, j) = Join(Jags(i, j), "") End If Next Next If rngErr Is Nothing Then '変更結果をクリップボードへ格納 SetCB Join2(Data, vbTab, vbCrLf) 'VBEデバッグ中ならSendKeyに支障が出るので消す '※Application.VBE.MainWindow.Visible = False は信頼性許可が必要なため使えない If ActiveWindowsIsVBE Then SendKeys "%{F4}", True DoEvents '貼り付け SendKeys "^v", True Else 'エラー箇所のセルを選択 rngErr.Select MsgBox "エラー : " & rngErr.Count & "件" End If End Sub
参考資料
正規表現関連
正規表現の作成にあたっては下記のサイトの仕様を参考に作成した。
https://excel-ubara.com/excelvba4/EXCEL232.html
クリップボード関連
クリップボードへの格納に関しては従来のDataObjectを使った方法は安定しないので、下記で紹介されている方法を使用した。
https://www.ka-net.org/blog/?p=7537
Windows API
まとめ
今回はオートフィルの強化版みたいなマクロを紹介しました。
このマクロをリボンに登録するなどして、すぐに呼び出せるようにしておくと便利だと思います。
あまり利用場面が無いなんて言わないで
また、「元に戻すを破壊しないVBAの書き方」も紹介しています。
色々な場面で使えるテクニックですが、特に支援ツール的なアドインを開発している人にとっては必須だと私は思います。是非ご活用下さい。
以上
何か御座いましたらコメント欄、またはTwitterからどうぞ♪
それではまた来週♪ ちゅんちゅん(・8・)