エクセルでのマクロを使った特殊な文字分け

質問

エクセルのマクロを使った処理について、初心者の小生にご教授ください。

今A列に文字列（半角全角混在）が入力されています。
この文字列の左から20文字までを同行のB列のセルに、21文字から40文字までを同行のC列のセルに、残りを同行のD列のセルに分割してコピーするマクロを作りたいと思っています。
しかし、文字数のカウントの仕方が特殊で悩んでいます。

カウントのルールは
1．半角は1文字、全角は2文字としてカウントする。

2．全角の場合はその文字の前と後ろに半角の『"』を入力し、それ自体も1文字としてカウントする。

3．全角が2個以上連続する場合は、その塊の前と後に『"』を入れる。（例:文字列が『あい』だとしたら、『"あ""い"』ではなく『"あい"』なるため、8文字ではなく6文字とカウントする。）

というルールです。
文字を分けるときに、分ける境目に文字が来てしまう場合（たとえば全角が20文字目と21文字目となる場合）は、右のセルに入力しなくてはいけません。
また、全角の前後にある『"』は全角とひとくくりとして考えるため、分けることはできません。（例:B列の最後が『あ』となって、C列の最初の文字が、その全角の後ろの『"』となることはできない。）
というややこしいルールとなっています。

文字列を左から順に確認していき、パターンで条件分けする方法も考えたのですが、処理が膨大になってしまい、こんがらがってしまいました。

何かすっきりとした解決方法はないものでしょうか。

ややこしい条件で分かりにくくで申し訳ございませんが、お知恵をお借りしたいと思います。
よろしくお願いいたします。

回答No.2

nanase_p_q_p_q · ベストアンサー

マクロの場合、以下のようにしてみてはいかがでしょうか。
長くてすみません。

'//------------------------------
'// 結果の格納用配列(B列～D列に相当)
'//------------------------------
Dim strSeparatedText(0 To 2) As String

'//------------------------------
'// 処理メイン
'//------------------------------
Public Sub Separate()
On Error Resume Next
Dim intRow As Integer
Dim intCol As Integer
Dim intEndRow As Integer

'// 1列1行目(A1)からデータのある最終行まで
intRow = 1
intCol = 1
intEndRow = ActiveSheet.UsedRange.End(xlDown).Row

'// 最終セルまで繰り返し
Do While intRow <= intEndRow
'// 文字を3つの文字列に分割
Call SeparateThreeText(ActiveSheet.Cells(intRow, intCol).Value)

'// B列～D列に結果の出力
ActiveSheet.Cells(intRow, intCol + 1).Value = strSeparatedText(0)
ActiveSheet.Cells(intRow, intCol + 2).Value = strSeparatedText(1)
ActiveSheet.Cells(intRow, intCol + 3).Value = strSeparatedText(2)

intRow = intRow + 1
Loop
End Sub

'//------------------------------
'// 文字を3つの文字列に分割
'//------------------------------
Private Sub SeparateThreeText(ByVal strText As String)

Dim strWork As String
Dim i As Integer '// 配列の添え字
Dim p1 As Long '// 文字列のp1文字目
Dim lngMaxLength As Long '// 配列の各要素に格納できるバイト数
Dim flgDoubleByte As Boolean '// 直前の文字が全角かどうかのフラグ

'// 配列の初期化
Erase strSeparatedText

'// 変数の初期化
i = 0
p1 = 1
strWork = ""
flgDoubleByte = False

'// 文字列の先頭から1文字ずつ検査
Do While True
'// 文字列の末尾まで終了した場合
If (p1 > Len(strText)) Then
'// 直前の文字が全角の場合
If (flgDoubleByte = True) Then
strWork = strWork & Chr(34)
End If
strSeparatedText(i) = strWork
Exit Do
End If

'// 配列の各要素に格納できるバイト数の設定
Select Case i
Case 0, 1
lngMaxLength = 20
Case Else
lngMaxLength = Len(strText) * 2 + 2
End Select

'// 配列に格納できるバイト数を超えた場合
If ((flgDoubleByte = False) And _
(LenB(StrConv(strWork, vbFromUnicode)) + _
LenB(StrConv(Mid(strText, p1, 1), vbFromUnicode)) > lngMaxLength)) Then

strSeparatedText(i) = strWork

strWork = ""
flgDoubleByte = False
i = i + 1
'// 配列に格納できるバイト数を超えた場合
ElseIf ((flgDoubleByte = True) And _
(LenB(StrConv(strWork, vbFromUnicode)) + _
LenB(StrConv(Mid(strText, p1, 1), vbFromUnicode)) + 1 > lngMaxLength)) Then
'// 直前の文字が全角の場合
If (flgDoubleByte = True) Then
strWork = strWork & Chr(34)
End If

strSeparatedText(i) = strWork

strWork = ""
flgDoubleByte = False
i = i + 1

End If

'// p1番目の文字が全角の場合
If (IsDoubleByte(Mid(strText, p1, 1)) = True) Then
'// 直前の文字が全角でない場合
If (flgDoubleByte = False) Then
strWork = strWork & Chr(34)
flgDoubleByte = True
End If

'// p1番目の文字が半角の場合
Else
'// 直前の文字が全角の場合
If (flgDoubleByte = True) Then
strWork = strWork & Chr(34)
flgDoubleByte = False
End If
End If

strWork = strWork & Mid(strText, p1, 1)

p1 = p1 + 1
Loop

End Sub

'//------------------------------
'// 文字が全角か半角かを判定
'//------------------------------
Private Function IsDoubleByte(ByVal strChar As String) As Boolean
'// 文字のバイト数と文字数の2倍を比較
If (LenB(StrConv(strChar, vbFromUnicode)) = Len(strChar) * 2) Then
'// 全角の場合
IsDoubleByte = True
Else
'// 半角の場合
IsDoubleByte = False
End If
End Function

お礼

ご回答ありがとうございます。
長いマクロの記述ありがとうございました。
実行してみたところ、私の希望通りの結果となりました。
質問No.3に空欄の扱い方の質問がございましたが、この結果で十分です。
ご教授いただいたマクロを見ても、一部動作内容がわからないところもありますが、
後学のため、勉強してみたいと思います。

ありがとうございました。

回答No.3

nanase_p_q_p_q

#2にて回答したnanaseです

回答のマクロについて少々の解説を加えます。

実行時は、関数[Separate]を実行してください。
「intRow = 1」としたため、1行目から開始します。

A列の文字列を引数に関数「SeparateThreeText」を
呼び出すことで、結果の格納用配列に結果が返却される
ようにしました。

添え字0番目をB列、1番目をC列、2番目をD列に順次
出力します。

この処理をintEndRowに自動計算された行まで繰り返します。

ところで、#2のマクロでは、20文字目や39文字目、40文字目に空白がある
場合を考慮に入れておりません。

前後の空白の除去など必要でしょうか？

回答No.1

某HN クロメート(Chromate)（@CoalTar）

少しは考えの足しになれば程度の回答ですm(_ _)m
文字数は256文字まで
B2セル =LEN(A2)

C2セル 第1全角
=MATCH(2,LENB(MID(A2&"あ",COLUMN(2:2),1)),0)
[Ctrl]+[Shift] +[Enter] で確定、配列数式です({}で囲まれる)
D2セル 第1半角
=MATCH(1,LENB(MID(A2&"0",COLUMN(2:2),1)),0)
[Ctrl]+[Shift] +[Enter] で確定、配列数式です({}で囲まれる)
B2:D2 下へオートフィル

E2セル 第2全角
=MATCH(2,LENB(MID(RIGHT($A2&"あ",$B2-D2+1),COLUMN(2:2),1)),0)+D2
[Ctrl]+[Shift] +[Enter] で確定、配列数式です({}で囲まれる)
F2セル 第2半角
=MATCH(1,LENB(MID(RIGHT($A2&"0",$B2-E2+1),COLUMN(2:2),1)),0)+E2
[Ctrl]+[Shift] +[Enter] で確定、配列数式です({}で囲まれる)
E2:F2セル 右へ下へオートフィル

これで「"」を入れられそうな気がする

お礼

ご回答ありがとうございました。
関数にて対応する方法ですね。
作業用のシートを作成する等で応用できそうです。
ありがとうございました。