[[20140324144850]]　『マクロで行を分ける方法』（wata）　ページの最後に飛ぶ

『マクロで行を分ける方法』（wata）

エクセルの一つのセルA1に

・あいうえお1234かきく，けこ
さし56すせそ
たちつ

という文字列が改行されて入っています。
これをマクロで，例えば全角５文字ずつ（もしくは4.5文字），セルに貼り付けていく方法を考えています。
さらに，文頭が「・」で始まるときは全角６文字，また「，」や「。」で始まらないようにしたいのです。

出力結果は，B1からB6まで

・あいうえお
1234かきく，
けこ
さし56すせ
そ
たちつ

となるようにしたいのです。

『正規表現の全角，半角の文字数カウント』など，質問で同じようなものがありましたが，セル内で改行してある場合が分かりません…。

どなたか，教えてください。よろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 何文字というか、10バイトずつってことだよね？
 ＞1234かきく，
 ＞さし56すせ

 力技！
Sub wata()
    Dim dic As Object
    Dim i As Long
    Dim x As Variant, y As Variant
    Dim tbl As Variant
    With CreateObject("System.Collections.ArrayList")
        For Each x In Split(Range("A1").Value, Chr(10))
            i = 1
            Do
                If Left(UMidB(x, i, 10), 1) = "・" Then
                    Debug.Print UMidB(x, i + 12, 2)
                    Select Case UMidB(x, i + 12, 2)
                        Case ",", ".", "，", "。"
                            .Add UMidB(x, i, 14): i = i + 14
                        Case Else
                            .Add UMidB(x, i, 12): i = i + 12
                    End Select
                Else
                    Debug.Print UMidB(x, i + 10, 2)
                    Select Case UMidB(x, i + 10, 2)
                        Case ",", ".", "，", "。"
                            .Add UMidB(x, i, 12): i = i + 12
                        Case Else
                            .Add UMidB(x, i, 10): i = i + 10
                    End Select
                End If
            Loop Until ULenB(UMidB(x, i, 10)) = 0
        Next x
         tbl = .toarray
        .Clear
    End With
    Range("B1").Resize(UBound(tbl) + 1) = Application.Transpose(tbl)
End Sub
Function UMidB(ByVal strData As String, ByVal s As Long, ByVal e As Long)
    UMidB = Application.Evaluate("MIDB(""" & strData & """," & s & "," & e & ")")
End Function
Function ULenB(ByVal strData As String)
    ULenB = Application.Evaluate("LENB(""" & strData & """)")
End Function
（稲葉） 2014/03/24(月) 17:01

『正規表現の全角，半角の文字数カウント』の最後のコードをもとに修正しました。

 Sub test()
    Dim myText As String
    Dim v
    Dim i As Long
    Dim p As Long
    Dim ss As String, s As String
    Dim b As Long
    Dim n As Long

    myText = Cells(1, "A").Text

    v = Split(myText, Chr(10))
    For i = 0 To UBound(v)
        ss = v(i)
        If Left(ss, 1) = "・" Then
            p = 12
        Else
            p = 10
        End If
        Do
            s = StrConv(LeftB(StrConv(ss, vbFromUnicode), p), vbUnicode)
            b = LenB(StrConv(s, vbFromUnicode))
            If b > p Then s = Left(s, Len(s) - 1)
            ss = Replace(ss, s, "")
            Select Case Left(ss, 1)
                Case ",", "，", "、", ".", "。"
                    s = s & Left(ss, 1)
                    ss = Mid(ss, 2)
            End Select
            Cells(1, "B").Offset(n).Value = s
            n = n + 1
         Loop While Len(ss) > 0
    Next

 End Sub

（マナ） 2014/03/24(月) 22:12
（マナ） 2014/03/24(月) 22:25　ちょとだけ修正

みなさん，ありがとうございます。
マナさんのはとてもスリムで良いのですが，

・あいうえおかきくけこさし

と，１行が長い文字列だとすると，

・あいうえお
かきくけこさ
し

と２行目も６文字になってしまいます…。
（wata） 2014/03/25(火) 00:10

5文字（10バイト）か6文字（12バイト）かは、pで指定しています。
なのでpを求める式をDo...Loopの中に入れます。どうでしょうか。

 Sub test2()
    Dim myText As String
    Dim v
    Dim i As Long
    Dim p As Long
    Dim ss As String, s As String
    Dim b As Long
    Dim n As Long

    myText = Cells(1, "A").Text

    v = Split(myText, Chr(10))
    For i = 0 To UBound(v)
        ss = v(i)
        Do
            p = IIf(Left(ss, 1) = "・", 12, 10)
            s = StrConv(LeftB(StrConv(ss, vbFromUnicode), p), vbUnicode)
            b = LenB(StrConv(s, vbFromUnicode))
            If b > p Then s = Left(s, Len(s) - 1)
            ss = Replace(ss, s, "")
            Select Case Left(ss, 1)
                Case ",", "，", "、", ".", "。"
                    s = s & Left(ss, 1)
                    ss = Mid(ss, 2)
            End Select
            Cells(1, "B").Offset(n).Value = s
            n = n + 1
         Loop While Len(ss) > 0
    Next

 End Sub

（マナ） 2014/03/25(火) 00:28

マナさん，ありがとうございました！
ばっちりな結果が出ました！！
IIF関数や，DOの中に入れることなど，大変勉強になりました。
感謝しております！

追加
Case ",", "，", "、", ".", "。"
の禁則処理文字の部分を，セルの値からひっぱってくるにはどうしたらいいか教えてくれませんか？

C1セルに
　",", "，", "、", ".", "。"
と，入るように数式を作ったとして，禁則処理文字を自由に変えたいのです。
Case Range("C1") Like ～
のようにLikeを使えばよさそうなことは分かったのですが…

（wata） 2014/03/25(火) 15:40　修正

Select CaseでなくIf文だと、Likeを使ってこんなことができます。

 C1に禁則文字を鍵カッコではさんで列挙 [,，、.。]

 Sub test3()
    If Range("D1").Value Like Range("C1").Value Then
    	MsgBox "D1は禁則文字です"
    End If
 End Sub

（マナ） 2014/03/25(火) 19:49

 ↑鍵カッコでなく角カッコですね。
（マナ） 2014/03/25(火) 22:01

コメント返信：

[ 一覧(最新更新順) ]

[[20140324144850]] 『マクロで行を分ける方法』（wata） ページの最後に飛ぶ

[[20140324144850]]　『マクロで行を分ける方法』（wata）　ページの最後に飛ぶ