1385205556 文字列をルールに従って配置するエクセルVBAを作成してください。


ある文字列が特定のセルに張り付いています。(今回は仮にA1)
そしてそこにカーソルが置かれているところでマクロを開始すると、

文字列から特定の規則に従って、切り取って、
エクセル内に整列して貼り付けてほしいのです。


ルール
【1】 ドットで区切られた部分が見出しとして、カーソルのおかれていた行のすぐ右の行におく
【2】 数字は下に1行はなして、1つずつ下に向かって置いていく。

【3】 英文字+数字が合計3-5文字程度でてきますが、それは、カーソルのあった1つ下のところに置く。(画像では数字はないですが、入ることがあります)


【4】 ドットが出てきた時点で改行の印と判断し、次の列に移る

【1】~【4】を繰り返し、最後にドットがなくなった時点で終了です。




文字列の例(カーソル内に下記が入っていたら、画像のような処理になってほしいのです)
.t1.5777537JRT.t11.5879967JRR.t2.7788747JRF.t22.7556727JRZ.t3.6773527WDW.t4.6777727WRT.n1.5775747WRR.n11.5779977WRJ

数字部分は現在7ケタですが、もっと増えることもあります。


お手数ですがよろしくお願いいたします。


回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/11/23 20:19:16
  • 終了:2013/11/24 00:28:59

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982013/11/23 21:54:25

ポイント200pt
Sub main()

Dim r As Long
Dim r1 As Long

c = Selection.Column
r = Selection.Row

d = Cells(r, c)

a = InStr(d, ".")
b = Right(d, Len(d) - a)
While b <> ""

    c = c + 1
    
    a = InStr(b, ".")
    s1 = Left(b, a - 1)
    d = Right(b, Len(b) - a)
   
    a = InStr(d, ".")
    f = 0
    If a = 0 Then a = Len(d): f = 1
    s2 = Left(d, a - 1 + f)
    b = Right(d, Len(d) - a)
   
    Cells(r, c) = s1
    
    m = 0
    For k = 1 To Len(s2)
        s3 = Mid(s2, k, 1)
        If s3 >= "0" And s3 <= "9" Then
            m = m + 1
            Cells(r + 1 + k, c) = s3
        End If
    Next k
    
    Cells(r + 1, c) = Right(s2, Len(s2) - m)
    
Wend


End Sub


id:naranara19

その節はお世話になりました!完璧でございました!早くて感謝します。

2013/11/24 00:28:30

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982013/11/23 21:54:25ここでベストアンサー

ポイント200pt
Sub main()

Dim r As Long
Dim r1 As Long

c = Selection.Column
r = Selection.Row

d = Cells(r, c)

a = InStr(d, ".")
b = Right(d, Len(d) - a)
While b <> ""

    c = c + 1
    
    a = InStr(b, ".")
    s1 = Left(b, a - 1)
    d = Right(b, Len(b) - a)
   
    a = InStr(d, ".")
    f = 0
    If a = 0 Then a = Len(d): f = 1
    s2 = Left(d, a - 1 + f)
    b = Right(d, Len(d) - a)
   
    Cells(r, c) = s1
    
    m = 0
    For k = 1 To Len(s2)
        s3 = Mid(s2, k, 1)
        If s3 >= "0" And s3 <= "9" Then
            m = m + 1
            Cells(r + 1 + k, c) = s3
        End If
    Next k
    
    Cells(r + 1, c) = Right(s2, Len(s2) - m)
    
Wend


End Sub


id:naranara19

その節はお世話になりました!完璧でございました!早くて感謝します。

2013/11/24 00:28:30
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912013/11/23 22:41:24

ポイント200pt

おもしろそうなので回答しただけですので、
最初の回答で解決したのであればポイント不要です。

Sub Sample()
    Set br = Selection
    dt = Split(IIf(Left(br.Value, 1) <> ".", ".", "") & br.Value, ".")
    c = br.Column
    For i = LBound(dt) + 1 To UBound(dt)
        If i Mod 2 = 1 Then
            c = c + 1
            Cells(br.Row, c).Value = dt(i)
            r = br.Row + 2
        Else
            For j = 1 To Len(dt(i))
                Select Case Mid(dt(i), j, 1)
                    Case "0" To "9"
                        Cells(r, c).Value = Mid(dt(i), j, 1)
                        r = r + 1
                    Case Else
                        Cells(br.Row + 1, c).Value = Mid(dt(i), j, Len(dt(i)))
                        Exit For
                End Select
            Next
        End If
    Next
End Sub
id:naranara19

その節はお世話になりすぎました!完璧でございました!速い方が有効かと思いますが、いるかはすみませんが、ポイントはもちろん差し上げます。これからもよろしくお願いいたします。

2013/11/24 00:28:34

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません