[[20130523151242]]　『セル内の文字列の操作』（サファ者）　ページの最後に飛ぶ

『セル内の文字列の操作』（サファ者）

IC1,IC2,IC3,IC4,IC6,IC8,IC10,IC11,IC12,IC14
この文字列を

IC1~4,6,8,10~12,14
のように変換させたいです。

内容なのですが、
・ローマ字の部分ICを先頭だけを残して削除
・3つ以上の連番は「~」を使って表す

よろしくお願いします

2003

 >・3つ以上の連番は「~」を使って表す

 2つ連番なら？

 それと、関数で？

 (ぶらっと)

  2,3,11はいらないのですか。

二つ連番であれば「,」で区切りたいです。
IC1,IC2,IC4,IC5,IC6であれば
IC1,2,4~6といったように。

マクロでお願いします。

2,3,11は
例えば
1~4は1から4までという意味で表すように考えていますので、
見た目で言うといらないです。
（サファ者）

 すこ～し、力技になったけど。　たとえば文字列がA1にあるとして。

 Sub Sample()
    Dim v As Variant
    Dim s As String
    Dim f As Long
    Dim t As Long
    Dim i As Long
    Dim w() As String
    Dim k As Long
    Dim x As Long

    s = Range("A1").Value & ","       'たとえば"

    v = Split(Replace(s, "IC", ""), ",")
    ReDim w(1 To UBound(v))

    f = LBound(v)
    For i = LBound(v) To UBound(v) - 1
        If Val(v(i)) + 1 <> Val(v(i + 1)) Then
            If i - f > 1 Then
                k = k + 1
                w(k) = v(f) & "~" & v(i)
            Else
                For x = f To i
                    k = k + 1
                    w(k) = v(x)
                Next
            End If
            f = i + 1
        End If
    Next

    ReDim Preserve w(1 To k)
    MsgBox Join(w, ",")

 End Sub

 Sub test()
    Dim cw As String
    Dim vw As Variant
    Dim i As Long
    Dim iFlag As Long
    Dim iw1 As Long
    Dim iw2 As Long

    vw = Split(Range("A1"), ",")
    cw = vw(0)
    iw2 = Mid(cw, 3)
    iFlag = 0

    For i = 1 To UBound(vw)
        If 0 < iFlag Then
            iw1 = iw1 + 1
        Else
            iw1 = iw2 + 1
        End If
        iw2 = Mid(vw(i), 3)
        If iw1 = iw2 Then
            iFlag = iFlag + 1
        Else
            If iFlag = 1 Then
                cw = cw & "," & (iw1 - 1) & "," & iw2
            ElseIf 1 < iFlag Then
                cw = cw & "~" & (iw1 - 1) & "," & iw2
            Else
                cw = cw & "," & iw2
            End If
            iFlag = 0
        End If
    Next i
    If iFlag = 1 Then
        cw = cw & "," & iw2
    ElseIf 1 < iFlag Then
        cw = cw & "~" & iw2
    End If

    MsgBox cw
End Sub

(???) 若干修正。

つかってみました、ありがとうございます。
メッセージボックスに表示ではなく、変換希望です。

説明がたりなかったのですが
同じ列に
IC1,IC2,IC3,IC4,IC6,IC8,IC10,IC11,IC12,IC14
R3,R4,R8,R9,R10,R13
ZNR6,ZNR9,ZNR10,ZNR11,ZNR12
のように文字列がありまして、それを一括でマクロで下記のように変換できるようにしたいです。

IC1~4,6,8,10~12,14
R3,4,8~10,13
ZNR6,9,10~12

お願いします。（サファ者）

ローマ字の部分は数種類あります、R,C,Q,IC,ZD,CN,ZNR。
（サファ者）

・ICやZNR等の混在はあり得る？　それとも必ず同じ項目は連続？
・R,C,Q,IC,ZD,CN,ZNRの順は固定？　ばらばら？
・ALT+ENTERで区切って、1セル複数行ということ？それとも1項目1セルずつ？
・IC14とR3の間にはカンマが無い？
・サンプルを参考として、自分で作ってみる気は全く無し？
(???)

 >メッセージボックスに表示ではなく、変換希望です。

 それはわかっていたけど、そのあたりは、そちらで応用で、セルに書き込んでくれたらいいので・・・

 >のように文字列がありまして

 つまり、それぞれの行での　アルファベット　が異なるということだね？

 (ぶらっと)

・混在はないです。同じ項目が連続します。
・順番はバラバラです。
・1項目1セルずつです。
・カンマはないです。ICとRは違う行にありますので。
・サンプルと参考書をみてチャレンジしてみます。

応用してみます。

それぞれの行でアルファベットは異なります。

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

（サファ者）

 書いたので参考出品。

 Sub Sample2()
    Dim v As Variant
    Dim s As String
    Dim f As Long
    Dim t As Long
    Dim i As Long
    Dim w() As String
    Dim k As Long
    Dim x As Long
    Dim c As Range
    Dim re As Object
    Dim mt As Object
    Dim prefix As String
    Application.ScreenUpdating = False

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[A-Z]+"

    For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
        s = c.Value & ","
        prefix = re.Execute(s).Item(0).Value
        v = Split(Replace(s, prefix, ""), ",")
        ReDim w(1 To UBound(v))
        k = 0

        f = LBound(v)
        For i = LBound(v) To UBound(v) - 1
            If Val(v(i)) + 1 <> Val(v(i + 1)) Then
                If i - f > 1 Then
                    k = k + 1
                    w(k) = v(f) & "~" & v(i)
                Else
                    For x = f To i
                        k = k + 1
                        w(k) = v(x)
                    Next
                End If
                f = i + 1
            End If
        Next

        ReDim Preserve w(1 To k)
        c.Value = prefix & Join(w, ",")

    Next

    Application.ScreenUpdating = True

 End Sub

 (ぶらっと)

1項目1セルならば、応用可能。

 Sub test()
    Dim cw As String
    Dim vw As Variant
    Dim i As Long
    Dim iR As Long
    Dim iFlag As Long
    Dim iw1 As Long
    Dim iw2 As Long

    For iR = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        vw = Split(Cells(iR, "A").Value, ",")
        cw = vw(0)
        iw2 = Fix(StrReverse(Val(StrReverse(vw(0) & "9"))) / 10)
        iFlag = 0

        For i = 1 To UBound(vw)
            If 0 < iFlag Then
                iw1 = iw1 + 1
            Else
                iw1 = iw2 + 1
            End If
            iw2 = Fix(StrReverse(Val(StrReverse(vw(i) & "9"))) / 10)
            If iw1 = iw2 Then
                iFlag = iFlag + 1
            Else
                If iFlag = 1 Then
                    cw = cw & "," & (iw1 - 1) & "," & iw2
                ElseIf 1 < iFlag Then
                    cw = cw & "~" & (iw1 - 1) & "," & iw2
                Else
                    cw = cw & "," & iw2
                End If
                iFlag = 0
            End If
        Next i
        If iFlag = 1 Then
            cw = cw & "," & iw2
        ElseIf 1 < iFlag Then
            cw = cw & "~" & iw2
        End If
        Cells(iR, "B").Value = cw
    Next iR
End Sub
(???)

 こんな感じで

 Sub test()
    Dim a, i As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Value
        For i = 1 To UBound(a, 1)
            a(i, 2) = Summarize(a(i, 1))
            ' a(i, 2) を a(i, 1) に変更すると A列を変換
        Next
        .Value = a
    End With
End Sub

 Function Summarize(ByVal txt As String) As String
    Dim temp As String, m As Object, flg As Boolean, i As Long
    Summarize = txt
    If txt Like "*[!A-Za-z0-9, ]*" Then Exit Function
    With CreateObject("VBScript.RegExp")
        .Pattern = "((\D+)(\d+,)+)\2(.*)"
        temp = .Replace(txt, "$2")
        Do While .test(txt)
            txt = .Replace(txt, "$1$4")
        Loop
        .Global = True
        .Pattern = "\d+"
        Set m = .Execute(txt)
        If m.Count > 1 Then
            temp = temp & m(0)
            For i = 1 To m.Count - 1
                If Val(m(i)) - Val(m(i - 1)) <> 1 Then
                    If flg Then
                        temp = temp & m(i - 1) & "," & m(i): flg = False
                    Else
                        temp = temp & "," & m(i)
                    End If
                Else
                    If Not flg Then
                        temp = temp & "~": flg = True
                    End If
                End If
            Next
        End If
    End With
    Summarize = temp
End Function
(seiya) チョイ修正 20:47

ぶらっとさん？？？さんseiyaさん
遅れましたがありがとうございました。
何通りもの書き方があって驚きました。
これを気に本格的に勉強を始めたいと思いました。
VBAエキスパーターになります！

すいません、何度も申し訳ないですが少し勘違いがありまして、
IC1,IC2,IC4,IC5,IC6であれば
IC1,IC2,IC4~6に
ということで~が手前についてる数字を除いて
すべての数字にローマ字をつけるような形にしたいのです。

ぶらっとさんのコードだとおそらく、下から4行目のprefixの部分に手を
加えればよさそうだと思うのですが、何を入れたらいいのかわかりません。

再度ご教授お願い致します。

 c.Value = prefix & Join(w, ",")

サファ者

自分の作った分で対応。

 Sub test()
    Dim cw As String
    Dim vw As Variant
    Dim i As Long
    Dim iR As Long
    Dim iFlag As Long
    Dim iw1 As Long
    Dim iw2 As Long

    For iR = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        vw = Split(Cells(iR, "A").Value, ",")
        cw = vw(0)
        iw2 = Fix(StrReverse(Val(StrReverse(vw(0) & "9"))) / 10)
        iFlag = 0

        For i = 1 To UBound(vw)
            If 0 < iFlag Then
                iw1 = iw1 + 1
            Else
                iw1 = iw2 + 1
            End If
            iw2 = Fix(StrReverse(Val(StrReverse(vw(i) & "9"))) / 10)
            If iw1 = iw2 Then
                iFlag = iFlag + 1
            Else
                If iFlag = 1 Then
                    cw = cw & "," & vw(i - 1) & "," & vw(i)
                ElseIf 1 < iFlag Then
                    cw = cw & "~" & (iw1 - 1) & "," & vw(i)
                Else
                    cw = cw & "," & vw(i)
                End If
                iFlag = 0
            End If
        Next i
        If iFlag = 1 Then
            cw = cw & "," & vw(i - 1)
        ElseIf 1 < iFlag Then
            cw = cw & "~" & iw2
        End If
        Cells(iR, "B").Value = cw
    Next iR
End Sub
(???)

 Sample2 でいえば

 c.Value = prefix & Join(w, ",")

 これを

 c.Value = prefix & Join(w, "," & prefix)

 (ぶらっと)

コメント返信：

[ 一覧(最新更新順) ]

[[20130523151242]] 『セル内の文字列の操作』（サファ者） ページの最後に飛ぶ

[[20130523151242]]　『セル内の文字列の操作』（サファ者）　ページの最後に飛ぶ