VBAの勉強を始めてみた

色々試しています。

指定文字列の左側または右側を切り出す

今回は指定文字列の左側または右側を切り出すコードを考えてみたいと思います。例えば、氏名から、スペースを境にして姓と名を切り出したい・・・・・・。とか。
ただ、そんなのは既に世の中にある気がするので、そこから半歩進んだ処理も考えてみたいと思います。

 

境にしたい指定文字列がセル内に複数ある場合、左から何個目かを指定できるようにする。

こんな感じ。

左から2個目の全角スラッシュを境にして、左側または右側を切り出したい。

f:id:kouten0430:20190816155420p:plain

 

左側を切り出した結果

f:id:kouten0430:20190816155449p:plain

 

右側を切り出した結果

f:id:kouten0430:20190816155517p:plain

 

ということで、コードを作ってみました。(ついでに、指定文字列を含んで切り出すかどうかも選択できるようにした)

左側を切り出すコード

Sub 指定文字の左側を切り出す()
    '選択範囲に対して処理を行います
    Dim 指定文字 As String
    DimAs Integer
    Dim tmp As Integer
    DimAs Integer
    Dim myRange As Range
    DimAs Integer
    Dim i As Integer
    Dim 位置 As Integer
    
    指定文字 = InputBox("指定文字を入力して下さい。")
        If 指定文字 = "" Then Exit Sub= InputBox("左から何個目の指定文字を境にしますか?")

    tmp = MsgBox("指定文字を含んで切り出しますか?", vbYesNoCancel)
        If tmp = vbYes Then= Len(指定文字)
        ElseIf tmp = vbNo Then= 0
        Else
            Exit Sub
        End If

    For Each myRange In Selection
        始 = 1  '検索開始位置

        For i = 2 To '左から2個目以降の指定文字を境にした場合の検索開始位置を求める
            If InStr(, myRange.Value, 指定文字) > 0 Then= InStr(, myRange.Value, 指定文字) + Len(指定文字)
            Else
                Exit For
            End If
        Next i
    
        位置 = InStr(, myRange.Value, 指定文字)
        
        If 位置 > 0 Then
            myRange.Value = Left(myRange.Value, 位置 +- 1)
        End If
        
    Next myRange
    
End Sub

 

右側を切り出すコード

Sub 指定文字の右側を切り出す()
    '選択範囲に対して処理を行います
    Dim 指定文字 As String
    DimAs Integer
    Dim tmp As Integer
    DimAs Integer
    Dim myRange As Range
    DimAs Integer
    Dim i As Integer
    Dim 位置 As Integer
    
    指定文字 = InputBox("指定文字を入力して下さい。")
        If 指定文字 = "" Then Exit Sub= InputBox("左から何個目の指定文字を境にしますか?")

    tmp = MsgBox("指定文字を含んで切り出しますか?", vbYesNoCancel)
        If tmp = vbYes Then= 0
        ElseIf tmp = vbNo Then= Len(指定文字)
        Else
            Exit Sub
        End If

    For Each myRange In Selection
        始 = 1  '検索開始位置

        For i = 2 To '左から2個目以降の指定文字を境にした場合の検索開始位置を求める
            If InStr(, myRange.Value, 指定文字) > 0 Then= InStr(, myRange.Value, 指定文字) + Len(指定文字)
            Else
                Exit For
            End If
        Next i
    
        位置 = InStr(, myRange.Value, 指定文字)
        
        If 位置 > 0 Then
            myRange.Value = Right(myRange.Value, Len(myRange.Value) - 位置 -+ 1)
        End If
        
    Next myRange
    
End Sub

※コードの使用方法

SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

実行手順

  1. 処理したい範囲を選択してマクロを実行する。
  2. InputBoxが表示されるので、指定文字列を入力する。(必ずしも、1文字である必要は無い)
  3. 引き続きInputBoxが表示されるので、左から何個目の指定文字列を境にするかを入力する。
  4. 指定文字列を含んで切り出すかどうかを、「はい」「いいえ」で選択する。

 

プログラムの説明

  • InputBoxおよびMsgBoxで処理に必要な情報の入力を促す。
  • For Each ~Nextで選択範囲に対して順番に処理を行う。
  • 文字列検索開始位置の初期値を1文字目とする。
  • For ~Nextの処理。境とする文字列を左から2個目以降とした場合の、文字列検索開始位置を求める。(左から1文字目とした場合、このループには入らない)
  • InStr関数で、指定文字列(n個目)の位置を求める。
  • 左側から(または右側から)指定文字列の手前までを切り出す。※指定文字列を含むを「はい」にした場合は、含んで切り出す。

 

余談ですが、Excel 2013以降であればフラッシュフィルで似たようなこともできます。(ただ、フラッシュフィルでは思った通りの結果にならないこともあったりする)

 

 

追記

ことりちゅんさんのコメントにあるように、Split関数の第三引数 Limitを活用したコードを作ってみました。元のコードは極力そのままでSplit関数に置き換えています。右側を切り出すコードに関してはかなりスッキリしました。

右側を切り出すコード(元コードとの違いを赤にしています)

Sub 指定文字の右側を切り出すlimit版()
    '選択範囲に対して処理を行います
    Dim 指定文字 As String
    Dim 境 As Integer
    Dim tmp As Integer
    Dim 含 As String
    Dim myRange As Range
    Dim 配列 As Variant
    
    指定文字 = InputBox("指定文字を入力して下さい。")
        If 指定文字 = "" Then Exit Sub
        
    境 = InputBox("左から何個目の指定文字を境にしますか?")

    tmp = MsgBox("指定文字を含んで切り出しますか?", vbYesNoCancel)
        If tmp = vbYes Then
            含 = 指定文字
        ElseIf tmp = vbNo Then
            含 = ""
        Else
            Exit Sub
        End If

    For Each myRange In Selection
        配列 = Split(myRange.Value, 指定文字, 境 + 1)
        myRange.Value = 含 & 配列(UBound(配列))
        
    Next myRange
    
End Sub

 

左側を切り出すコード(上記、右側を切り出すコードとの違いを紫にしています) 

Sub 指定文字の左側を切り出すlimit版()
    '選択範囲に対して処理を行います
    Dim 指定文字 As String
    Dim 境 As Integer
    Dim tmp As Integer
    Dim 含 As String
    Dim myRange As Range
    Dim 総数 As Integer
    Dim 配列 As Variant
    
    指定文字 = InputBox("指定文字を入力して下さい。")
        If 指定文字 = "" Then Exit Sub
        
    境 = InputBox("左から何個目の指定文字を境にしますか?")

    tmp = MsgBox("指定文字を含んで切り出しますか?", vbYesNoCancel)
        If tmp = vbYes Then
            含 = 指定文字
        ElseIf tmp = vbNo Then
            含 = ""
        Else
            Exit Sub
        End If

    For Each myRange In Selection
        総数 = (Len(myRange.Value) - Len(Replace(myRange.Value, 指定文字, ""))) / Len(指定文字)   'セル内の指定文字の総数を求める
        配列 = Split(StrReverse(myRange.Value), StrReverse(指定文字), 総数 - 境 + 2)
        myRange.Value = StrReverse(配列(UBound(配列))) & 含
        
    Next myRange
    
End Sub

 

ある行の高さや列幅を、他の行または列に適用する

エクセルを使用していると、行の高さや列の幅をコピーして他の行・列に適用したいときがあります。
そんなときはどうすればいいでしょうか?

 目次

 

形式を選択して貼り付けする方法

数式や書式のみをコピーして貼り付けできるのと同じように、列幅のみをコピーして貼り付けることができます。

f:id:kouten0430:20190816150633p:plain

 

・・・・・・あれ?行高さは?
なぜか、形式を選択して貼り付けする方法には行高さのみをコピペする機能がありません。

 

高さや幅を確認してから、他の行・列に設定する方法

これが一番原始的な方法です。お手本にしたい行や列の境目あたり(カーソルの形が変わる所)でクリックして、値を確認し

f:id:kouten0430:20190816150834p:plain

 

次に、値を同じにしたい行または列を選択した状態で右クリック→「行の高さ(または列の幅)」で同じ値を入力してOKします。

f:id:kouten0430:20190816150859p:plain

 

ただし、値を確認し、入力する手間があります。

 

マクロで適用する方法

上の方法でも十分なのですが、ちょっとだけ(ほんのちょっとだけ)簡単にできるマクロを作ってみました。

Sub 行の高さや列幅を他の行または列に適用する()
    '適用先の行全体または列全体を選択した状態で実行する
    'インプットボックスで適用元の行または列を指定する
    Dim 列番号 As String
    Dim 列幅 As Double
    Dim 行番号 As Long
    Dim 行高さ As Double
    
    If Selection.Address = Selection.EntireColumn.Address Then
        列番号 = InputBox("列幅の適用元となる列番号をアルファベットで指定")
        列番号 = StrConv(列番号, vbNarrow)
        
        If 列番号 Like "*[!A-Za-z]*" Then GoTo エラー処理
        
        On Error GoTo エラー処理
            列幅 = Columns(列番号).ColumnWidth
        On Error GoTo 0
        
        Selection.ColumnWidth = 列幅
        
    ElseIf Selection.Address = Selection.EntireRow.Address Then
        行番号 = InputBox("行高さの適用元となる行番号を指定")
        
        On Error GoTo エラー処理
            行高さ = Rows(行番号).RowHeight
        On Error GoTo 0
        
        Selection.RowHeight = 行高さ
    
    End If
    
    Exit Sub

エラー処理:
    MsgBox "存在しない行または列です。"
End Sub

※コードの使用方法

SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

実行手順

  1. 高さや幅を変更したい行または列を選択した状態でマクロを実行。
  2. InputBoxが表示されるので、お手本にしたい行または列を入力してOKする。※行は数字、列はアルファベットで入力する。

 

・・・・・・ここまで書いてアレですが、マクロを用意するほどでもなかったかも。

複数のセルの色でフィルタリングを行う

前回は複数の文字の色でしたが、今回は複数のセルの色でフィルタリングしてみましょう。内容は一部、前回と重複しますのでご了承ください。

kouten0430.hatenablog.com


エクセルのオートフィルターはセルの色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルの色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。

VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。(たぶん)

 

ということで、複数のセルの色でフィルタリングできるコードを作ってみました。
(今回は二つのコードを使います)

コード1

Sub セル色の値を改行区切りでクリップボードに格納()
    '格納する値はリトルエンディアンです
    
    Dim myRange As Range
    Dim V As String
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    If Selection.Count > 1 Then
        For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
            If myRange.Address = myRange.MergeArea(1).Address Then   '結合セルの場合は左上の値のみ取り出す
                V = V & myRange.Interior.Color & vbCrLf
            End If
        Next myRange
        
        V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く(CrLfは2文字)
        
    Else
        V = ActiveCell.Interior.Color
        
    End If
    
    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する

End Sub

 

コード2

Sub 複数のセルの色で絞込みを行う()
    'クリップボードに格納されたセル色の値を参照し、OR条件で絞込みします
    '実行前に絞り込みを行う列範囲(見出しを除く)を選択しておきます
    'セル色が一致しない行を非表示にします(オートフィルターを使いません)
    Dim V As Variant
    Dim i As Integer
    Dim x As Integer
    Dim y As Long
    Dim Yn As Long
    Dim myRange As Range
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    Application.ScreenUpdating = False  '画面表示の更新をオフにする
    
    myLib.GetFromClipboard
        On Error Resume Next
    V = myLib.GetText
        On Error GoTo 0
        
    If Not IsEmpty(V) Then
        V = Split(CStr(V), vbCrLf)
        x = Selection.Column

        For y = Selection.Row To Selection.Rows(Selection.Rows.Count).Row
            i = 0
        
            Do While i <= UBound(V)
                If CStr(Cells(y, x).Interior.Color) = V(i) Then '配列の内容と一致している場合は行を進める
                        Yn = y + 1
                        Do While Cells(y, x).Address = Cells(Yn, x).MergeArea(1).Address    '結合セルを抜けるまで行を進める
                            Yn = Yn + 1
                        Loop
                        y = Yn - 1
                    
                    GoTo nx
                Else
                    i = i + 1
                End If
            Loop
            
            If myRange Is Nothing Then
                Set myRange = Range(y & ":" & y)    '配列の内容全てと一致しなかった一番最初の行
            Else
                Set myRange = Union(myRange, Range(y & ":" & y))    '配列の内容全てと一致しなかった行
            End If
             
nx:
        Next y
        
        myRange.EntireRow.Hidden = True '検索に一致しなかった行をすべて非表示にする
    Else
        MsgBox "クリップボードにデータがありません!"
    End If

End Sub

※コードの使用方法 SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

 実行手順

  1. まず、フィルターに使用したい色のセルを複数選択した状態で、コード1を実行します。(この処理でセル色の値がクリップボードに一時保存されます)
  2. フィルタリングしたい列の範囲を選択し、コード2を実行します。

 

実行風景(事前に実行手順の1.で赤・青・黄のセル色を取得済み)

f:id:kouten0430:20190815141123g:plain

フィルタリング解除は、標準機能で行を再表示しています。

 

プログラムの説明

  • 割愛

 

課題

  • 二つのコードを使うので煩雑。
  • クリップボードを使う方法は安定しない場合がある。(私の環境だと、クリップボードへのアクセスに数百回に一度失敗するかどうかなので実用上問題なし)
  • フィルタリング範囲を手動で選択するのが面倒。※自動で選択させる方法(CurrentRegionを使う方法・シートの最終行からEnd(xlUp)する方法・罫線の有無で判定する方法)もあるけど、表の作り方は人によって千差万別なので確実に自動選択できる保証がない・・・・・・。
  • フィルタリングの解除が面倒。

複数の文字の色でフィルタリングを行う

エクセルのオートフィルターは文字の色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルのフォント色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。(たぶん)


ということで、複数の文字の色でフィルタリングできるコードを作ってみました。
(今回は二つのコードを使います)

コード1

Sub 文字色の値を改行区切りでクリップボードに格納()
    '格納する値はリトルエンディアンです
    '複数の文字色が混在するセルはNullとなります
    
    Dim myRange As Range
    Dim V As String
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    If Selection.Count > 1 Then
        For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
            If myRange.Address = myRange.MergeArea(1).Address Then   '結合セルの場合は左上の値のみ取り出す
                V = V & myRange.Font.Color & vbCrLf
            End If
        Next myRange
        
        V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く(CrLfは2文字)
        
    Else
        V = ActiveCell.Font.Color
        
    End If
    
    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する

End Sub

 

コード2

Sub 複数の文字の色で絞込みを行う()
    'クリップボードに格納された文字色の値を参照し、OR条件で絞込みします
    '実行前に絞り込みを行う列範囲(見出しを除く)を選択しておきます
    '文字色が一致しない行を非表示にします(オートフィルターを使いません)
    Dim V As Variant
    Dim i As Integer
    Dim x As Integer
    Dim y As Long
    Dim Yn As Long
    Dim myRange As Range
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    Application.ScreenUpdating = False  '画面表示の更新をオフにする
    
    myLib.GetFromClipboard
        On Error Resume Next
    V = myLib.GetText
        On Error GoTo 0
        
    If Not IsEmpty(V) Then
        V = Split(CStr(V), vbCrLf)
        x = Selection.Column

        For y = Selection.Row To Selection.Rows(Selection.Rows.Count).Row
            i = 0
        
            If Not IsNull(Cells(y, x).Font.Color) And Not Cells(y, x).Value = "" Then '複数の文字色が混在するセル(Null)と空白のセル(黒と値が重複)は、検索の対象外
                Do While i <= UBound(V)
                    If CStr(Cells(y, x).Font.Color) = V(i) Then '配列の内容と一致している場合は行を進める
                            Yn = y + 1
                            Do While Cells(y, x).Address = Cells(Yn, x).MergeArea(1).Address    '結合セルを抜けるまで行を進める
                                Yn = Yn + 1
                            Loop
                            y = Yn - 1
                    
                        GoTo nx
                    Else
                        i = i + 1
                    End If
                Loop
            End If
            
            If myRange Is Nothing Then
                Set myRange = Range(y & ":" & y)    '配列の内容全てと一致しなかった一番最初の行
            Else
                Set myRange = Union(myRange, Range(y & ":" & y))    '配列の内容全てと一致しなかった行
            End If
             
nx:
        Next y
        
        myRange.EntireRow.Hidden = True '検索に一致しなかった行をすべて非表示にする
    Else
        MsgBox "クリップボードにデータがありません!"
    End If

End Sub

※コードの使用方法

SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

実行手順

  1. まず、フィルターに使用したい文字色のセルを複数選択した状態で、コード1を実行します。(この処理で文字色の値がクリップボードに一時保存されます)
  2. フィルタリングしたい列の範囲を選択し、コード2を実行します。

 

実行風景(事前に実行手順の1.で赤・青・黄の文字色を取得済み)

f:id:kouten0430:20190815135018g:plain

フィルタリング解除は、標準機能で行を再表示しています。

 

プログラムの説明
◇コード1

  • 選択されたセルからFont.Colorで文字色の値を取得し、末尾に改行を付け足して変数に代入する
  • 選択されたすべてのセルに対して、上記を繰り返す
  • 最後に処理したセルの改行が邪魔なので取り除く
  • 変数の内容をクリップボードに転送する

 

◇コード2

  • クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
  • 現在選択している範囲の列番号を取得する
  • For Nextの始まりの値を選択範囲の上端の行、終わりの値を下端の行をする
  • まずは上端の行から、配列内のデータと一致するか否か比較を行う
  • 配列内のいずれかのデータと一致していれば、Next yへ飛ぶ(一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める)
  • 配列内のデータすべてと一致しなかった場合は、その行をUnionメソッドで記憶しておく
  • 下端の行まで、For ~Nextの繰り返し
  • 最後に、検索に一致しなかった行をまとめて非表示にする
  • また、下のように複数の文字色が混在するセルは、Font.Colorの値がNullとなるため検索の対象外とし、すべて非表示にする。

    f:id:kouten0430:20190815135244p:plain

    空白のセルはFont.Colorの値が黒の文字色と同じになるので、これも検索の対象外とし、すべて非表示にする。

 

課題

  • 二つのコードを使うので煩雑。
  • クリップボードを使う方法は安定しない場合がある。(私の環境だと、クリップボードへのアクセスに数百回に一度失敗するかどうかなので実用上問題なし)
  • フィルタリング範囲を手動で選択するのが面倒。※自動で選択させる方法(CurrentRegionを使う方法・シートの最終行からEnd(xlUp)する方法・罫線の有無で判定する方法)もあるけど、表の作り方は人によって千差万別なので確実に自動選択できる保証がない・・・・・・。
  • フィルタリングの解除が面倒。

同じデータのセルを結合する

今回は隣接するセルのデータが同じであれば、セル結合する。というコードを作ってみたいと思います。

しかし、

「セル結合はなるべく避けるべし」

「すぐにセル結合したがる民は滅んでほしい」

「最初からこの機能が無ければよかった」

と、いうような声もよく耳にします。
確かに、多くの人でデータを共有したりするようなエクセルシートであれば、エクセルの便利な機能が殺されてしまい、思わぬ迷惑をかけてしまうことがあります。
しかし、使い捨てで、他人に渡すようなものでなければ、見やすくするためにちょっとくらい結合したっていいじゃん。という思いもあったりします。

 

実際、私はよくやります。(←ぇ)

 

だからといって、手動で1個ずつ結合していくのも面倒くさいです。なので「縦方向(または横方向)に隣接するセルのデータが同じならセル結合する」というコードを作ってみました。禁忌を積極的に破るようで気が引けますけどね・・・・・・。

Sub 同じデータのセルを結合する()
    DimAs Long
    DimAs Long
    Dim 行終 As Long
    Dim 列終 As Long
    Dim myUni As Range

    Application.DisplayAlerts = False

    If Selection.Rows.Count > 1 And Selection.Columns.Count = 1 Then    '下方向に選択したときの処理= Selection.Column
        行 = Selection.Row + 1
        行終 = Selection.Rows(Selection.Rows.Count).Row
        
        Do While<= 行終
            If Cells(- 1,).MergeArea(1).Value = Cells(,).MergeArea(1).Value Then
                If myUni Is Nothing Then
                    Set myUni = Range(Cells(- 1,), Cells(,))
                Else
                    Set myUni = Union(myUni, Cells(,))
                End If
            Else
                If Not myUni Is Nothing Then
                    myUni.Merge
                    Set myUni = Nothing
                End If
            End If=+ 1

        Loop
            
    ElseIf Selection.Rows.Count = 1 And Selection.Columns.Count > 1 Then '右方向に選択したときの処理= Selection.Row
        列 = Selection.Column + 1
        列終 = Selection.Columns(Selection.Columns.Count).Column
        
        Do While<= 列終
            If Cells(,- 1).MergeArea(1).Value = Cells(,).MergeArea(1).Value Then
                If myUni Is Nothing Then
                    Set myUni = Range(Cells(,- 1), Cells(,))
                Else
                    Set myUni = Union(myUni, Cells(,))
                End If
            Else
                If Not myUni Is Nothing Then
                    myUni.Merge
                    Set myUni = Nothing
                End If
            End If=+ 1

        Loop
        
    End If
    
    If Not myUni Is Nothing Then    '行終または列終を含むセルの結合
        myUni.Merge
    End If

End Sub

※コードの使用方法

SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

プログラムの説明

  • 割愛

 

実行風景

f:id:kouten0430:20190812152629g:plain

縦方向・横方向のどちら側に選択しているかはプログラムが自動判別してくれます。

集計の機能を犠牲にして、刹那的に見やすくするだけの他愛のないコードですね( ̄q ̄;)

 

 冒頭でも触れましたが、公の場でセル結合を乱用すると謎の勢力に命を狙われますので、その点は注意して下さい。

文字列中の数字に指定値を加減算する

今回は文字列の途中(もしくは先頭や末尾)に存在する数字に、指定値を加減算させてみたいと思います。んで、ついでに指定値でインクリメント・デクリメントなんかもさせたい。
処理のイメージはこんなの。

f:id:kouten0430:20190811142927p:plain

 

f:id:kouten0430:20190811142947p:plain

 

f:id:kouten0430:20190811143016p:plain

 

f:id:kouten0430:20190811143045p:plain

 

欲を言えば、全角数字でも処理できるようにしたい。

f:id:kouten0430:20190811143134p:plain

 

ということで作りました。

Sub 文字中の数字に指定値を加減算する()
    '選択範囲に対して処理を行います
    '数字は半角・全角どちらでも処理可(漢数字は処理不可)
    '処理対象の数字の桁数を維持します
    DimAs String
    Dim ns As Integer
    Dim ne As Integer
    DimAs Long
    Dim tmp As Integer
    Dim myRange As Range
    Dim 数値 As Long
    Dim 数字 As String
    Dim 増量 As Long= "000000000"
    
    ns = InputBox("左から何文字目を開始位置にしますか?")
    ne = InputBox("開始位置から何文字の数字を対象にしますか?")= InputBox("加算する値を入力して下さい。" & vbCrLf & "(マイナスの値を入力すると減算になります)")
    tmp = MsgBox("入力した値で選択順にインクリメントしますか?", vbYesNo + vbDefaultButton2)

    For Each myRange In Selection.SpecialCells(xlCellTypeVisible)
        If myRange.Value <> "" And TypeName(myRange.Value) <> "Date" Then   'セルの値が空白,日付の場合は処理をしない
            数値 = Mid(myRange.Value, ns, ne)
            数値 = 数値 ++ 増量
            
            If 数値 < 0 Then 数値 = 0  '減算した値が0未満の場合は0を下限とする
            
            If tmp = vbYes Then 増量 = 増量 + 'インクリメントする場合の処理
            
            If Mid(myRange.Value, ns, ne) = StrConv(Mid(myRange.Value, ns, ne), vbWide) Then
                数字 = StrConv(Right(& 数値, ne), vbWide)
            Else
                数字 = Right(& 数値, ne)
            End If
            
            myRange.Value = Application.WorksheetFunction.Replace(myRange.Value, ns, ne, 数字)
            
        End If
        
    Next myRange
    
End Sub

※コードの使用方法

SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

プログラムの説明

  • 割愛

 

課題

  • 処理対象の数字が左から何文字目か・・・・・・等々をユーザーが入力する必要があり、めんどくさい(処理対象セルが数百あるなら些細な手間ですが)。
  • 複数のセルを処理対象にするのなら、データの規則性(数字の位置・文字数 等々)が一致している必要がある。
  • 漢数字やローマ数字は処理不可。

 

以下の記事では、オートフィルでカウントアップされなかった他の数値をカウントアップする方法を紹介しています。目的は少し異なりますが、私のものと違い、操作感はかなりスマートです。また、処理結果を元に戻すことが可能。

www.excel-chunchun.com

クイックアクセスツールバーのユーザー設定を特定のブックのみに登録する

今回は、クイックアクセスツールバーのボタンを特定のブックのみに登録する方法を紹介します。
やり方はとても簡単。以下のとおりです。

 

  1. ファイル-オプション-クイックアクセスツールバーを選択
  2. クイックアクセスツールバーのユーザー設定を「すべてのドキュメントに適用(規定)」から「Book1に適用」に変更します。※Book1は必要に応じて任意のブック名とする

    f:id:kouten0430:20190810151912p:plain

  3. この状態でコマンドを追加する
  4. OKを押す

 

これで、Book1を保存すると上の手順で登録したボタンはBook1にのみ保存されます。

こんな感じ。

f:id:kouten0430:20190810144130p:plain

 

ブックに、ちょっとしたシート共通マクロをつけて配布するときなどに便利です。(ただし、「マクロを起動するボタンはコレだよ」ということを何らかの形で明示しておく必要あり)