えくせるちゅんちゅん

ことりがエクセルをちゅんちゅんするブログ

MENU
トップ > Excel > VBAでセルに含まれる全ての数値をカウントアップするマクロを作成する

VBAでセルに含まれる全ての数値をカウントアップするマクロを作成する

Excel VBA VBAマクロ

今回はVBAでオートフィルの強化版みたいなのを作ってみましたので紹介します。

尚、本記事では「元に戻すを破壊しないVBAの書き方」も記載しています。

使用風景

f:id:Kotori-ChunChun:20190502041046g:plain

きっかけ

稀に単一のセルに含まれた複数の数値を、合わせてカウントアップさせたい時がある。

ところが、オートフィルを使うとこんな風に右端の数値しかカウントアップしてくれない。

オートフィル
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

概要

基本方針としては、オートフィルを実行した直後の選択範囲に対してマクロを追加実行することで、オートフィルの結果を強化するという感じで開発した。

第一弾は単純に選択範囲の先頭行を下方向へフィルする例。

２次元配列に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でもルールに沿って使用すれば全く問題ない。簡易的なマクロならこれで完成形と言って良いだろう。

でも作ってからしばらくしたらルール＝使い方なんて覚えていない。

そしてデータが破壊される恐れがあるようなマクロは、私なら怖くて使えない。

というわけで、範囲内のデータが先頭行と同じ仕様であることを検査した上で、全く問題無い場合のみデータを書き換えるようにしてみた。

不適切なデータが見つかった場合は、セルを黄色く塗りつぶすようにした。

尚、実務では末尾に文字を付け足す事があるため、後半部分はなにが増えようが許容するように設計している。

f:id:Kotori-ChunChun:20190502042849p:plain

ソースコード

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を実行すれば保持するのは難しくない。

f:id:Kotori-ChunChun:20190502041046g:plain

その前に、前提として使用する関数が増えたので先に記載しておく。

前提関数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

GetActiveWindow

FindWindowA


まとめ

今回はオートフィルの強化版みたいなマクロを紹介しました。

このマクロをリボンに登録するなどして、すぐに呼び出せるようにしておくと便利だと思います。

あまり利用場面が無いなんて言わないで

また、「元に戻すを破壊しないVBAの書き方」も紹介しています。

色々な場面で使えるテクニックですが、特に支援ツール的なアドインを開発している人にとっては必須だと私は思います。是非ご活用下さい。

以上

何か御座いましたらコメント欄、またはTwitterからどうぞ♪

それではまた来週♪　ちゅんちゅん(・8・)

プライバシーポリシー