エクセルVBAの文字列操作について2

質問

エクセルVBAの文字列操作について2

以前、こちらでご教授いただいた以下のような文字列操作方法があります。
この方法ですと例えば[1-3]から3をひいた際に"1-2"と表示されますが
今回は連続する数字が2つの場合は1,2と表示させ3つ以上の場合は-でつないで表示させたいと思います。
一週間ほど考えたのですが解決できませんでした。
どなたかご協力お願いいたします。

質問内容
例えば、[１－１０,15-20,22-38]と入っているセルがあるとします。
このセルに数を足したり引いたりしたいのです。
例えば、このセルから”5”を引いて[１-4,6-１０,15-20,22-38]と表示したり、
"21"を足して[１－１０,15-38]と表示したい。

いただいたご回答

　A1 セル に「1-10,12,15-20,22-38」と入力されているとして、別のセルに
=NUMORDER(A1,-5)
と入力すると「1-4,6-10,12,15-20,22-38」と表示し
=NUMORDER(A1,21)
と入力すると「1-10,12,15-38」と表示します。

　１つ目の引数には「セル番地」または「文字列」を、２つ目の引数には「1 ～ 99 までの整数」をお入れください。

Function NUMORDER(myStr As Variant, num As Integer) As String
　Dim i As Long
　Dim j As Double
　Dim myNum As Variant

'文字列中の スペース を削除
　myStr = Replace(myStr, " ", "")

'文字列の前後に「0」・「100」を挿入
　Select Case Left(myStr, 2)
　　Case "1,", "1-"
　　　myStr = myStr & ",100"
　　Case Else
　　　myStr = "0," & myStr & ",100"
　End Select

'文字列を カンマ で分割し、ハイフン の区間の数字を補完する
　myStr = Split(myStr, ",")
　For i = 0 To UBound(myStr)
　　If InStr(myStr(i), "-") > 0 Then
　　　myNum = Split(myStr(i), "-")
　　　myStr(i) = ""
　　　For j = myNum(0) To myNum(1)
　　　　myStr(i) = myStr(i) & " " & j
　　　Next
　　　myStr(i) = Trim(myStr(i))
　　End If
　Next

'欠番に「●」を入れ、「数を足したり引いたり」する
　myStr = Split(Join(myStr))
　For i = 0 To UBound(myStr) - 1
　　myStr(i) = myStr(i) & Application.WorksheetFunction.Rept(" ●", myStr(i + 1) - myStr(i) - 1)
　Next
　myStr = Split(Join(myStr))
　If num > 0 Then
　　myStr(num - myStr(0)) = num
　Else
　　myStr(-num - myStr(0)) = "●"
　End If

'前後に挿入した「0」・「100」を削除
　myStr = Replace(Join(myStr), " 100", "")
　If Left(myStr, 2) = "0 " Then myStr = Right(myStr, Len(myStr) - 2)

'連続数字を ハイフン で繋ぐ
　myStr = Split(myStr, "●")
　For i = 0 To UBound(myStr)
　　If myStr(i) <> " " Then
　　myNum = Split(Trim(myStr(i)))
　　　If UBound(myNum) > 0 Then
　　　　myStr(i) = myNum(0) & "-" & myNum(UBound(myNum))
　　　End If
　　End If
　Next

'カンマ で文字列に分割する
　myStr = Application.Trim(Join(myStr))
　NUMORDER = Replace(myStr, " ", ",")
End Function

回答No.5

Wendy02

#4のコードですが、

>A1:[1-10,15-20,22-38]
>=SerialLinker(A1,-39)
>1-4,6-10,15-20,22-38

そのような結果にはならないはずです。

A1:[1-10,15-20,22-38]
=SerialLinker(A1,-39)
結果：1-10,15-20,22-38
となります。
**

>1-4,6-10,15-20,22-38
とするには、
=SerialLinker(A1,-5)

となります。

>のような形ですと全て削除されてしまうようです。

こちらで試してみましたが、そのようなことはありませんね。間違った入力をすれば、概ね、#VALUE!エラーが発生するはすです。どうすれば、すべて削除されるのですか？VBAプロシージャから使わないと、削除されることはないはずです。

回答No.4

Wendy02

#2の回答者です。

前のパラメータ配列（複数の引数)で行ったほうがよいとは思うのですが、理解出来ていないようなので、以下のように変更しました。数のダブリを抜くコードは入れました。扱いは正数に限ります。

A1:[1-10,15-20,22-38]

=SerialLinker(A1,-5)
1-4,6-10,15-20,22-38

=SerialLinker(A1,21)
1-10,15-38

=SerialLinker(A1,-3)
1,2,4-10,15-20,22-38

'//
Public Function SerialLinker(ByVal Nums As Variant, arg As Variant)
Dim arNum, arTmp, Ar() As Long, Ar2() As Long
Dim i As Long, j As Long, m As Long, k As Long
Dim n As Variant, a As Long, b As Long
Dim buf As String, flg As Boolean
If IsNumeric(Nums) Then Exit Function
Nums = StrConv(Nums, vbNarrow)

If Nums Like "[[]#*" Then
　　Nums = Mid(Nums, 2, Len(Nums) - 2)
End If
arNum = Split(Nums, ",")
For Each n In arNum
　　If InStr(n, "-") Then
　　　　arTmp = Split(n, "-")
　　　　If arTmp(1) > arTmp(0) Then
　　　　　　a = arTmp(0): b = arTmp(1)
　　　　Else
　　　　　　a = arTmp(1): b = arTmp(0)
　　　　End If
　　　　For i = a To b
　　　　　　ReDim Preserve Ar(j)
　　　　　　Ar(j) = i
　　　　　　j = j + 1
　　　　Next
　　Else
　　　　ReDim Preserve Ar(j)
　　　　Ar(j) = n
　　　　j = j + 1
　　End If
Next n
ReDim Preserve Ar(j)
Ar(j) = Abs(arg)
ReDim Ar2(UBound(Ar))

If arg >= 0 Then
　　k = 0
　　For i = LBound(Ar) To UBound(Ar)
　　　　　Ar2(i) = Application.Small(Ar, i + 1)
　　Next
　　For i = LBound(Ar2) To UBound(Ar2)
　　　　　If i < UBound(Ar2) Then
　　　　　　If Ar2(i) <> Ar2(i + 1) Then
　　　　　　　Ar2(k) = Ar2(i)
　　　　　　　k = k + 1
　　　　　　End If
　　　　　Else
　　　　　　Ar2(k) = Ar2(i)
　　　　　End If
　　Next
Else
　　j = 0
　　For i = LBound(Ar) To UBound(Ar) - 1
　　　　If Ar(i) <> Abs(arg) Then
　　　　　　Ar2(j) = Ar(i)
　　　　　　j = j + 1
　　　　End If
　　Next
　　ReDim Preserve Ar2(j - 1)
End If
buf = Ar2(0)
j = UBound(Ar2)
For i = 1 To j
　　If Ar2(i) = Ar2(i - 1) + 1 Then
　　　　flg = True: m = m + 1
　　ElseIf flg Then
　　　　If m = 1 Then
　　　　　　buf = buf & "," & Ar2(i - 1) & "," & Ar2(i)
　　　　Else
　　　　　　buf = buf & "-" & Ar2(i - 1) & "," & Ar2(i)
　　　　End If
　　　　flg = False: m = 0
　　ElseIf Ar2(i) <> Ar2(i - 1) Then
　　　　buf = buf & "," & Ar2(i)
　　　　flg = False
　　End If
Next
If flg Then buf = buf & "-" & Ar2(i - 1)
SerialLinker = buf
End Function

お礼

見事に連続数字が処理されていますね。
半分程しかコードが理解出来なかったので
勉強させていただきます。

ただ、
A1:[1-10,15-20,22-38]
=SerialLinker(A1,-39)
1-4,6-10,15-20,22-38

のような形ですと全て削除されてしまうようです。

回答No.3

jcctaira

プログラムがやや複雑になっていると思い、多少シンプル？に作成してみました。
配列を文字列にして「１」「０」の位置で数値の有無を表わしています。
その他はプログラムを見て理解して下さい。

Function NUMORDER(ByVal myStr As Variant, num As Integer) As String
　Dim I　　　　As Integer
　Dim J　　　　As Integer
　Dim 開始値　 As Integer
　Dim 終了値　 As Integer
　Dim 数列　　 As String
　Dim K区切り　As Variant
　Dim H区切り　As Variant

　数列 = String(101, "0")
　K区切り = Split(myStr, ",")
　For I = 0 To UBound(K区切り)
　　H区切り = Split(K区切り(I), "-")
　　開始値 = H区切り(0)
　　終了値 = H区切り(UBound(H区切り))
　　For J = 開始値 To 終了値
　　　Mid(数列, J, 1) = "1"
　　Next J
　Next I
　If num > 0 Then Mid(数列, num, 1) = "1"
　If num < 0 Then Mid(数列, -num, 1) = "0"
　I = 1
　Do
　　I = InStr(I, 数列, "1")
　　If I <= 0 Then Exit Do
　　If NUMORDER <> "" Then NUMORDER = NUMORDER & ","
　　J = InStr(I, 数列, "0")
　　NUMORDER = NUMORDER & I
　　If I <> (J - 1) Then NUMORDER = NUMORDER & "-" & J - 1
　　I = J
　Loop
End Function

お礼

すばらしい！ここまでまとめられるものなのですね。
勉強させていただきます。

回答No.2

Wendy02

前回のようにお礼もコメントも書かないで締めるのはマナーに関わります。点は、あくまでも、OkWaveの決め事であって、点はお礼の代わりにはなりません。

私の関数は、加える・引くが同じ関数で出来ることと、複数の引数が可能です。
=SerialChecker(A1,FALSE, 5) 引く　または、=SerialChecker(A1,0, 5)
=SerialChecker(A1,TRUE, 5) 足す　または、=SerialChecker(A1,1, 5)

文字制限のために、以下はVBAの書法を守っていませんが、これは便宜的なものです。

'//
Public Function SerialChecker(ByVal Nums As Variant, EraseFlg As Boolean, ParamArray AddVal())
Dim arNum, arTmp, Ar() As Long, Ar2() As Long
Dim i As Long, j As Long, k As Long, m As Long
Dim n, c, ret, a As Long, b As Long
Dim arBuf, buf As String, flg As Boolean
If IsNumeric(Nums) Then Exit Function
Nums = StrConv(Nums, vbNarrow)
If Nums Like "[[]#*" Then
　　Nums = Mid(Nums, 2, Len(Nums) - 2)
End If
arNum = Split(Nums, ",")
For Each n In arNum
　　If InStr(n, "-") Then
　　　　arTmp = Split(n, "-")
　　　　If arTmp(1) > arTmp(0) Then
　　　　　　a = arTmp(0): b = arTmp(1)
　　　　Else
　　　　　　a = arTmp(1): b = arTmp(0)
　　　　End If
　　　　For i = a To b
　　　　　　ReDim Preserve Ar(j)
　　　　　　Ar(j) = i
　　　　　　j = j + 1
　　　　Next
　　Else
　　　　ReDim Preserve Ar(j)
　　　　Ar(j) = n
　　　　j = j + 1
　　End If
Next n
If IsArray(AddVal) Then
　　arBuf = Array(AddVal)
End If
If EraseFlg Then 'Add
　　For Each c In AddVal
　　　　ReDim Preserve Ar(j)
　　　　Ar(j) = c
　　　　j = j + 1
　　Next
　　ReDim Ar2(j - 1)
　　For i = 0 To j - 1
　　　　Ar2(i) = Application.Small(Ar, i + 1)
　　Next
Else
　　j = 0
　　For Each c In Ar
　　　　ret = Application.Match(c, arBuf, 0)
　　　　If IsError(ret) Then
　　　　　　ReDim Preserve Ar2(j)
　　　　　　Ar2(j) = c
　　　　　　j = j + 1
　　　　End If
　　Next
　　For i = 0 To j - 1
　　　　Ar2(i) = Application.Small(Ar2, i + 1)
　　Next
End If
buf = Ar2(0)
For i = 1 To j - 1
　　If Ar2(i) = Ar2(i - 1) + 1 Then
　　　　flg = True: m = m + 1
　　ElseIf flg Then
　　　　If m = 1 Then
　　　　　 buf = buf & "," & Ar2(i - 1) & "," & Ar2(i)
　　　　Else
　　　　　buf = buf & "-" & Ar2(i - 1) & "," & Ar2(i)
　　　　End If
　　　　flg = False: m = 0
　　ElseIf Ar2(i) <> Ar2(i - 1) Then
　　　　buf = buf & "," & Ar2(i)
　　　　flg = False
　　End If
Next
If flg Then buf = buf & "-" & Ar2(i - 1)
SerialChecker = buf
End Function

お礼

ご指摘に感謝致します。
複数の引数で行えるのですね。勉強させていただきます。

回答No.1

layy

"1-2"のところを"1,2"ですから、
NUMORDERの結果からさらに、
開始－終了の差が１しかない（連続している）を判定できれば
ＯＫということでしょうか？。
「－」を見つけて前の数値後の数値を比較・・・、
また「－」を見つけて比較・・・、の繰り返し？。

前回の対応者に聞くのが早いと思いますが・・・。
'連続数字を ハイフン で繋ぐ
の
myStr(i) = myNum(0) & "-" & myNum(UBound(myNum))
付近と思われます。

補足

ご指摘のように「－」を見つけて前の数値後の数値を比較・・・
ということを考えて以下のようなコードを考えていましたが
かなり長くなったのでもっとスマートにやる方法はないかと思った次第です。

全体 = Len(NUMORDER)
ハイフン除いた数 = Replace(NUMORDER, "-", "")
ハイフン個数 = 全体 - Len(ハイフン除いた数)
ハイフンの位置 = InStr(NUMORDER, "-")

If ハイフンの位置 > 0 Then
Else
GoTo label900
End If

NUMORDER = "," & NUMORDER & ","
ハイフンの位置 = InStr(NUMORDER, "-")

Do Until ハイフンの位置 < 1

If ハイフンの位置 > 0 Then

ハイフンの左の位置 = ハイフンの位置 - 1
ハイフンの左 = Mid(NUMORDER, ハイフンの位置 - 1, 1)
ハイフンの右 = Mid(NUMORDER, ハイフンの位置 + 1, 1)

左1 = Mid(NUMORDER, ハイフンの位置 - 2, 1)
右1 = Mid(NUMORDER, ハイフンの位置 + 2, 1)

If 左1 = "," Then
ハイフンの左 = Mid(NUMORDER, ハイフンの位置 - 1, 1)
Else
ハイフンの左 = Mid(NUMORDER, ハイフンの位置 - 2, 2)
End If

If 右1 = "," Then
ハイフンの右 = Mid(NUMORDER, ハイフンの位置 + 1, 1)
Else
ハイフンの右 = Mid(NUMORDER, ハイフンの位置 + 1, 2)
End If

If ハイフンの左 + 1 = ハイフンの右 Then
Mid(NUMORDER, ハイフンの位置, 1) = ","
End If
End If

ggg = InStr(NUMORDER, "-")

ハイフンカウント = ハイフンカウント + 1
If ハイフン個数 = ハイフンカウント Then
Exit Do
End If

If ggg = 0 Then
Exit Do
End If

ハイフンの位置 = InStr(ハイフンの位置 + 1, NUMORDER, "-")

Loop

総数 = Len(NUMORDER)
NUMORDER = Mid(NUMORDER, 2, 総数 - 2)

label900: