文字列をルールに従って配置するエクセルVBAを作成してください。
ある文字列が特定のセルに張り付いています。（今回は仮にA1）
そしてそこにカーソルが置かれているところでマクロを開始すると、
文字列から特定の規則に従って、切り取って、
エクセル内に整列して貼り付けてほしいのです。
ルール
【１】 ドットで区切られた部分が見出しとして、カーソルのおかれていた行のすぐ右の行におく
【２】 数字は下に１行はなして、１つずつ下に向かって置いていく。
【３】 英文字＋数字が合計3-5文字程度でてきますが、それは、カーソルのあった１つ下のところに置く。（画像では数字はないですが、入ることがあります）
【４】 ドットが出てきた時点で改行の印と判断し、次の列に移る
【１】～【４】を繰り返し、最後にドットがなくなった時点で終了です。
文字列の例（カーソル内に下記が入っていたら、画像のような処理になってほしいのです）
.t1.5777537JRT.t11.5879967JRR.t2.7788747JRF.t22.7556727JRZ.t3.6773527WDW.t4.6777727WRT.n1.5775747WRR.n11.5779977WRJ
数字部分は現在７ケタですが、もっと増えることもあります。
お手数ですがよろしくお願いいたします。
No.1
13539
1198
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
No.1
135391198
ここでベストアンサー
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
その節はお世話になりました！完璧でございました！早くて感謝します。
No.2
1314393
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
その節はお世話になりすぎました！完璧でございました！速い方が有効かと思いますが、いるかはすみませんが、ポイントはもちろん差し上げます。これからもよろしくお願いいたします。
74
74
2
その節はお世話になりました！完璧でございました！早くて感謝します。
2013/11/24 00:28:30