(VBA)文字列を指定位置から抜き出す
Office2019,Windows10
文字列の指定位置から文字列の最後までを抜き出すコード(文字列())を作成しました。
現在は、指定文字列位置を指定するのに目で数えて指定しますが
数え間違えが多いのでミスを少なくする方法を検討しました。
以前教えてもらったコード(Nubering3())が利用したいのですが、
イメージだけでどうしたらいいか分かりません。
イメージとしては、
1)range(A1)の文字列で添付画像のような画像を表示して、
画像の下部に「どこから? 数値を入力してください」と表示して
抜き出し開始位置の数値を入力する
添付画像のように文字数が多くなると行が長くなるので
40文字毎に改行されて表示させる
(改行が難しい場合は、それに代わる方法でもOKです。)
2)数値が入力されれば、最初の画像(のような)は消えて
B列に抜き出し結果が表示される。
----------------------------------------------------------------
Sub Mid文字列()
Dim MojiSuu As Single
Dim KokoKara As Variant
Dim I As Single
Dim Nukidashi As String
Dim EndRow As Single
EndRow = Cells(1, "A").End(xlDown).Row
KokoKara = Application.InputBox(prompt:="どこから? 数値を入力してください", Title:="数値入力", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
For I = 1 To EndRow
MojiSuu = Len(Range("A" & I))
Nukidashi = Mid(Range("A" & I), KokoKara, MojiSuu)
Range("B" & I) = L
Next I
End Sub
---------------------------------------------------------------
Sub Nubering3()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, WRow As Long
Dim uRows As Range, uRange As Range
Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")
Set uRows = Ws2.Rows(1)
Set uRange = Ws2.Range("A2")
'Numberシートの初期化(全体=数式・文字・書式・コメント全てをクリア)
Ws2.Range("A1:XX100").Clear
Application.ScreenUpdating = False
For i = 2 To Ws1.Cells(Rows.Count, "A").End(xlUp).Row
WRow = Ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If Ws2.Range("A1").Value = "" And WRow = 2 Then
WRow = 1
End If
Set uRows = Union(uRows, Ws2.Rows(WRow))
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(WRow, j).Value = j
Ws2.Cells(WRow + 1, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, j))
Next
Next i
'Numeling 大文字、中央揃え
uRows.HorizontalAlignment = xlCenter
uRows.Font.Bold = True
'分割文字中央揃え罫線外枠
uRange.HorizontalAlignment = xlCenter
uRange.Borders.LineStyle = xlContinuous
'セル幅を見やすく
Ws2.Range("A1:xx100").ColumnWidth = 3
Application.ScreenUpdating = True
Ws2.Activate
Set Ws1 = Nothing
Set Ws2 = Nothing
Set uRows = Nothing
Set uRange = Nothing
End Sub