特定記号を基に末尾から文字数調整(ExcelVBA)

ゆーしゃん
2021.12.30
94 views

概要

長文を指定バイト数まで自動で文字数調整を行う

下記画像では1000バイト以上の文言を1000バイト以下に文字数調整を行っています。

上記画像では文章末尾から「 」「。」「！」記号を対象に指定バイト数以下になるように調整します。
↓調整イメージ

◆調整前文言
昔、おばあさんと三匹の子ブタがいました。 
ある時、おばあさんが子ブタたちに言いました。 
「この家にはもう食べる物がないよ！みんなここを出て、幸せをおさがし。」

◆1回目調整(末尾にある「。」までを削除。1000バイト以下になっていない場合は続けて調整
昔、おばあさんと三匹の子ブタがいました。 
ある時、おばあさんが子ブタたちに言いました。 
「この家にはもう食べる物がないよ！みんなここを出て、幸せをおさがし。」

◆2回目調整(更に末尾にある「！」までを削除。1000バイト以下になっていない場合は続けて調整
昔、おばあさんと三匹の子ブタがいました。 
ある時、おばあさんが子ブタたちに言いました。 
「この家にはもう食べる物がないよ~~！みんなここを出て、幸せをおさがし。」~~

◆3回目調整(更に末尾にある「 」までを削除。1000バイト以下になっていない場合は続けて調整
昔、おばあさんと三匹の子ブタがいました。 
ある時、おばあさんが子ブタたちに言いました。 
「この家にはもう食べる物がないよ！みんなここを出て、幸せをおさがし。」

…上記を1000バイト以下になるまで繰り返します。

プログラムを作成した理由

とある求人データの「仕事内容」「待遇福利厚生」等の文章が2000バイト以上の長文で記載されており、
文字数上限値以下(1000バイト以下)に文字数調整する必要がありました。

上記画像では2～6行目の文章だけですが、
毎日1000行以上の文字数調整を行う必要があり、

1文章辺り1分時間がかかるとして…
1000行 × 1分 = 1000分(16.66時間…)
もかかってしまいます…！

アルバイトや派遣社員を複数人雇って
上記の文字数調整をさせていたので、

「え、それ1秒で出来ますよ…！？」
と無駄な作業から解放してあげたかった為。

実装内容&導入方法

下記リンクから「文字数調整ツール」をダウンロードする

【サンプル】文字数調整ツール.xlsmダウンロード

ダウンロードしたツールのプロパティを開く

「セキュリティ」の「許可する」にチェックし、
「適応」「OK」ボタンを押す

この作業を行う事でツールが動くようになります。

ツールを開き、
「文字数調整」シートB列「調整前_文章」に文字数調整したい文章を貼り付け
※A列「タイトル」は何も記載しなくとも構いません。

ツール内にはサンプル文章が入っている為、
不要ならば削除してから文字数調整したい文章を貼り付けてください。

D2セル内の「OverByteDelete」内の第三引数「1000」を調整したいバイト数に修正する

例えば
「500バイト」以下に調整したい場合は
下記のように「500」と設定すれば自動的に「500」バイト以下まで調整されます。

=OverByteDelete(B2,文字数記号指定!$A$3,500)

D2セル関数をD列全体にコピペする

「文字数記号指定」シートA3セルに文字数調整対象記号をカンマ区切りで記載する

下記画像では文章末尾から「 」「。」「！」を対象に指定バイト数以下になるように調整します。

仮に「☆」を追加したい場合はA3セル内に
 ,。,！,☆
とカンマ区切りで記載して下さい。

「文字数調整」シートに戻り、E列「調整後_バイト数」が指定バイト数以下になっている事を確認

文章内に指定した記号が殆ど存在しない場合は、
1000バイト以内に収まらない可能性があります。

その場合「文字数調整対象記号」を最適化して下さい。

ソースコード

Option Explicit
'前提：ユーザー関数として使用
'概要：文言を末尾記号から文字数調整し、出力
'返却値：文字数調整後文言
'第一引数：文字数調整文言
'第二引数：記号リスト(カンマ区切り)
'第三引数：バイト数上限
Function OverByteDelete(ByVal 文言 As String, ByVal 記号 As Variant, ByVal バイト数 As Integer) As String
                                        
    '変数定義
    Dim TempByte As Integer
    Dim TempStr As String
    Dim LimitByte As Integer
    Dim Before_Str As String
    Dim After_Str As String
    Dim Temp_Mark As String
    Dim Match_Position As Integer
    Dim Match_Position_List() As Integer
    Dim Min_Result As Integer
    Dim Zero_Count As Integer
    Dim Min_Result_Mark As String
    Dim ColomnNum As Integer
    Dim Target_MarkList As Variant
    
    'ループカウンタ
    Dim i As Integer
    
    'ヒット位置と、ヒット記号を格納するコネクション
    Dim Match_Position_Collection As New Collection
    
    '配列に記号を分割格納
    Target_MarkList = Split(記号, ",")
    
    'ヒット位置格納配列初期化
    ReDim Match_Position_List(LBound(Target_MarkList) To UBound(Target_MarkList))
    
    'バイト数上限値格納
    LimitByte = バイト数
    
    '初期化
    Min_Result_Mark = ""
    
    '文言取得
    Before_Str = 文言
    TempStr = Before_Str
    
    '文言が空白の場合、チェックしない
    If Before_Str <> "" Then
        'バイト数取得(改行2バイト計算)
        TempByte = Get_Byte(Before_Str)
        
        '変更前文言を左右逆転
        After_Str = StrReverse(Before_Str)
        
        'バイト数がオーバーしなくなるまでループ
        Do While TempByte > LimitByte
                                                                                    
            '初期化
            Zero_Count = 0
            
            'ヒット位置と、ヒット記号を格納するコネクション初期化
            Set Match_Position_Collection = New Collection
            
            '対象記号ループ
            For i = LBound(Target_MarkList) To UBound(Target_MarkList)
                
                '記号格納
                Temp_Mark = Target_MarkList(i)
                
                '記号も左右逆転
                Temp_Mark = StrReverse(Temp_Mark)
                
                'ヒット位置格納
                Match_Position = InStr(After_Str, Temp_Mark)
                
                '最小値検索用_位置配列に格納
                Match_Position_List(i) = Match_Position
                
                'ヒット位置
                Select Case Match_Position
                    
                    '「0」ヒットカウント増加
                    Case 0: Zero_Count = Zero_Count + 1
                    
                    '1以上の場合、最小値から該当記号抽出用コネクションに格納
                    'Key：ヒット位置,Item：該当記号(左右逆転)
                    Case Is > 0: Match_Position_Collection.Add Temp_Mark, CStr(Match_Position)
                    
                    Case Else: MsgBox "マイナス指定はありえない"
                
                End Select
                
            Next
            
            'バイト数がオーバーしていても、該当記号が1個もない場合は終了
            If Zero_Count = UBound(Target_MarkList) + 1 Then
                Exit Do
            End If
            
            '「0」の次にある最小値を格納
            Min_Result = Application.WorksheetFunction.Small(Match_Position_List, Zero_Count + 1)
                            
            '最小値から記号取得
            Min_Result_Mark = Match_Position_Collection(CStr(Min_Result))
            
            '該当記号から先頭までを抽出
            After_Str = Mid(After_Str, Min_Result, Len(After_Str))
            
            '先頭該当記号を除外する
            After_Str = Application.WorksheetFunction.Substitute(After_Str, Min_Result_Mark, "", 1)
                                                                                            
            'バイト数取得(改行2バイト計算)
            '※左右判定を戻した状態で判定しないと改行コードが2バイト換算されない
            TempByte = Get_Byte(StrReverse(After_Str))
            
        Loop
        
        '左右反転を戻す
        After_Str = StrReverse(After_Str)
        
        '文字数調整結果反映
        If Before_Str <> After_Str Then
            OverByteDelete = After_Str
        Else
            OverByteDelete = Before_Str
        End If
    
    End If
    
    '破棄
    Set Match_Position_Collection = Nothing
    
End Function
'概要：改行コードを2バイト換算し、バイト数を返却
Private Function Get_Byte(Target_Str As String) As Integer
    
    Get_Byte = LenB(StrConv(WorksheetFunction.Substitute(Target_Str, "<BR>", "改"), vbFromUnicode))
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

Option Explicit

'前提：ユーザー関数として使用

'概要：文言を末尾記号から文字数調整し、出力

'返却値：文字数調整後文言

'第一引数：文字数調整文言

'第二引数：記号リスト(カンマ区切り)

'第三引数：バイト数上限

Function OverByteDelete(ByVal 文言 As String, ByVal 記号 As Variant, ByVal バイト数 As Integer) As String

'変数定義

Dim TempByte As Integer

Dim TempStr As String

Dim LimitByte As Integer

Dim Before_Str As String

Dim After_Str As String

Dim Temp_Mark As String

Dim Match_Position As Integer

Dim Match_Position_List() As Integer

Dim Min_Result As Integer

Dim Zero_Count As Integer

Dim Min_Result_Mark As String

Dim ColomnNum As Integer

Dim Target_MarkList As Variant

'ループカウンタ

Dim i As Integer

'ヒット位置と、ヒット記号を格納するコネクション

Dim Match_Position_Collection As New Collection

'配列に記号を分割格納

Target_MarkList = Split(記号, ",")

'ヒット位置格納配列初期化

ReDim Match_Position_List(LBound(Target_MarkList) To UBound(Target_MarkList))

'バイト数上限値格納

LimitByte = バイト数

'初期化

Min_Result_Mark = ""

'文言取得

Before_Str = 文言

TempStr = Before_Str

'文言が空白の場合、チェックしない

If Before_Str <> "" Then

'バイト数取得(改行2バイト計算)

TempByte = Get_Byte(Before_Str)

'変更前文言を左右逆転

After_Str = StrReverse(Before_Str)

'バイト数がオーバーしなくなるまでループ

Do While TempByte > LimitByte

'初期化

Zero_Count = 0

'ヒット位置と、ヒット記号を格納するコネクション初期化

Set Match_Position_Collection = New Collection

'対象記号ループ

For i = LBound(Target_MarkList) To UBound(Target_MarkList)

'記号格納

Temp_Mark = Target_MarkList(i)

'記号も左右逆転

Temp_Mark = StrReverse(Temp_Mark)

'ヒット位置格納

Match_Position = InStr(After_Str, Temp_Mark)

'最小値検索用_位置配列に格納

Match_Position_List(i) = Match_Position

'ヒット位置

Select Case Match_Position

'「0」ヒットカウント増加

Case 0: Zero_Count = Zero_Count + 1

'1以上の場合、最小値から該当記号抽出用コネクションに格納

'Key：ヒット位置,Item：該当記号(左右逆転)

Case Is > 0: Match_Position_Collection.Add Temp_Mark, CStr(Match_Position)

Case Else: MsgBox "マイナス指定はありえない"

End Select

'バイト数がオーバーしていても、該当記号が1個もない場合は終了

If Zero_Count = UBound(Target_MarkList) + 1 Then

Exit Do

End If

'「0」の次にある最小値を格納

Min_Result = Application.WorksheetFunction.Small(Match_Position_List, Zero_Count + 1)

'最小値から記号取得

Min_Result_Mark = Match_Position_Collection(CStr(Min_Result))

'該当記号から先頭までを抽出

After_Str = Mid(After_Str, Min_Result, Len(After_Str))

'先頭該当記号を除外する

After_Str = Application.WorksheetFunction.Substitute(After_Str, Min_Result_Mark, "", 1)

'バイト数取得(改行2バイト計算)

'※左右判定を戻した状態で判定しないと改行コードが2バイト換算されない

TempByte = Get_Byte(StrReverse(After_Str))

Loop

'左右反転を戻す

After_Str = StrReverse(After_Str)

'文字数調整結果反映

If Before_Str <> After_Str Then

OverByteDelete = After_Str

Else

OverByteDelete = Before_Str

End If

'破棄

Set Match_Position_Collection = Nothing

End Function

'概要：改行コードを2バイト換算し、バイト数を返却

Private Function Get_Byte(Target_Str As String) As Integer

Get_Byte = LenB(StrConv(WorksheetFunction.Substitute(Target_Str, " ", "改"), vbFromUnicode))

End Function

感想

今回のユーザー関数(マクロ)を作成した事により、
単純作業から解放してあげる事に成功致しました…が、

ある担当者からは
「あの単純作業で半日過ごせていたのになぁ」と嫌味を言われました(笑)

「こんな単純作業していないで、人間らしいクリエイティブな仕事して欲しい」
と思うのは私のエゴなのだろうか？と悩まされた一件でした。