（VBA)文字列を指定位置から抜き出す

質問

Office2019，Windows10

文字列の指定位置から文字列の最後までを抜き出すコード（文字列（））を作成しました。
現在は、指定文字列位置を指定するのに目で数えて指定しますが
　数え間違えが多いのでミスを少なくする方法を検討しました。

以前教えてもらったコード（Nubering3()）が利用したいのですが、
イメージだけでどうしたらいいか分かりません。

イメージとしては、
　１）range(A1)の文字列で添付画像のような画像を表示して、
　　画像の下部に「どこから？　数値を入力してください」と表示して
　　抜き出し開始位置の数値を入力する

　　添付画像のように文字数が多くなると行が長くなるので
　　　40文字毎に改行されて表示させる
　　　（改行が難しい場合は、それに代わる方法でもOKです。）

　２）数値が入力されれば、最初の画像（のような）は消えて
　　　　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

回答No.1

kkkkkm · ベストアンサー

Numberシートに40文字毎で改行して表示して指定した数値で抜き出し、最後にNumberシートはクリアします。

DATAシートのA列の最終行まで繰り返します。

Sub Mid文字列()

Dim MojiSuu As Single
Dim KokoKara As Variant

Dim i As Single
Dim Nukidashi As String
Dim EndRow As Single

With Sheets("DATA")
EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To EndRow
Nubering3 (i)
KokoKara = Application.InputBox(prompt:="どこから？　数値を入力してください", Title:="数値入力", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
.Activate
MojiSuu = Len(.Range("A" & i))
Nukidashi = Mid(.Range("A" & i), KokoKara, MojiSuu)
.Range("B" & i) = Nukidashi
Next i
End With
Sheets("Number").Range("A1:XX100").Clear
End Sub

Sub Nubering3(ByVal DataRow As Long)

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, WRow As Long, WColumn 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
WRow = 1: WColumn = 1
For j = 1 To Len(Ws1.Cells(DataRow, "A").Value)
Ws2.Cells(WRow, WColumn).Value = j
Ws2.Cells(WRow + 1, WColumn).Value = Mid(Ws1.Cells(DataRow, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, WColumn))
Set uRows = Union(uRows, Ws2.Rows(WRow))
If j Mod 40 = 0 Then
WRow = WRow + 3
WColumn = 1
Else
WColumn = WColumn + 1
End If
Next

'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

お礼

回答ありがとうございます。

おかげさまでイメージどうりの処理が出来てきました。

Numberシート内に表示される番号及び罫線内の文字をもう少し小さく表示したいのですが
フォントサイズの指定はどこに挿入したら良いでしょうか？

Sub Nubering3中に以下のようにフォントサイズを挿入してみましたが
　うまく処理できませんでした。

Set uRange = Ws2.Range("A2")

ws2.cells.font.size=10　＜-----------------------挿入追加分

'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア）

回答No.9

kkkkkm

Ws2.Range("A1:XX100").Clear
は
Ws2.Range("A1:" & XX & "100").Clear

みたいなイメージなのになぜ直接XXなの？
だったのですね。
変数でXとかYとか使うのでXXを変数的に見てしまうのは納得です。

お礼

kkkkkmさん、今回もお付き合い願いありがとうございます。
おかげさまで無事解決しました。

最後は、なんとも情けない追加質問で大変失礼しました。

次回も質問を見つけたら宜しくお願いします。

回答No.8

kkkkkm

> 下記のXXでエラーが出ないのが不思議なのですが？
>
> Ws2.Range("A1:XX100").Clear

すみません、問題点が全く思い浮かびません。
XX列はありますから問題はないと思ってますが、何か問題となる点があるでしょうか。

補足

>XX列はありますから問題はないと思ってますが、何か問題となる点があるでしょうか。

恥ずかしい限りです。

最大行数 は、1048576と使い切れないほ数値と理解していましたが
列数は調べると最大列数 … 16384列でXFDまであるのですね。
　XXと変数のように思ってしまったのでとんでもない勘違いをしていました。

回答No.7

kkkkkm

> 以下のおかしなところがあれば修正をお願いします。

修正というか念のためということで

付け忘れだと思いますが

Moto = Cells(i, "A")

のCellsの前にドットが抜けています。

Moto = .Cells(i, "A").Value

あと忘れてましたが
Range()とCells()の値を利用する場合には.Valueを付けておいた方がいいです。

Range("B1:B5") = Range("A1:A5")
だとB1:B5にA1:A5のデータが代入されませんが
Range("B1:B5") = Range("A1:A5").Value
もしくは
Range("B1:B5").Value = Range("A1:A5").Value
だと代入されます。

補足

検証ありがとうございます。

No.5の下記は、同じモノが2個ある場合は使えないとの事なので
　Replace(mStr, Mid(mStr, kokokara, kokomade - kokokara + 1), "")

No.4の下記を採用する事にしました
　　Left(mStr, kokokara - 1) & Mid(mStr, kokomade + 1)

>Moto = Cells(i, "A")のCellsの前にドットが抜けています。
>Range()とCells()の値を利用する場合には.Valueを付けておいた方がいいです。

下記のように修正しました。
　　Moto = .Cells(i, "A").Value

-----------------------------------------------------
ところで、
あまり深く考えずに以前から修正していないで利用していますが
下記のXXでエラーが出ないのが不思議なのですが？

Ws2.Range("A1:XX100").Clear

回答No.6

kkkkkm

No5の補足です。

"今日は、平成3年３月12日（月曜日）（月曜日）です。"

から（月曜日）を一つだけ消したい場合には使えません。

回答No.5

kkkkkm

削除するというイメージだと、以下のような感じで試してみてください。

Sub Test2()
Dim mStr As String
Dim kokokara As Long
Dim kokomade As Long

kokokara = 14
kokomade = 18

mStr = "今日は、平成3年３月12日（月曜日）です。"
Debug.Print Replace(mStr, Mid(mStr, kokokara, kokomade - kokokara + 1), "")

End Sub

回答No.4

kkkkkm

> 　今日は、平成3年３月12日（月曜日）です。
> の１４番目と18番目を指定して
> 　今日は、平成3年３月12日です。
> とする場合です。

その部分だけのコードですが、指定範囲以外を抜き出すと考えてLeftとMidを使って試してみてください。

Sub Test()
Dim mStr As String
Dim kokokara As Long
Dim kokomade As Long

kokokara = 14
kokomade = 18

mStr = "今日は、平成3年３月12日（月曜日）です。"
Debug.Print Left(mStr, kokokara - 1) & Mid(mStr, kokomade + 1)

End Sub

お礼

アドバイスありがとうございます。

削除型型は、最初にここから、ここまでを指定すれば
　後は、同じ処理で良いので下記のようにコードを作成しています。
　　（成型後の文字列をテキストとして別途保存も作成）

以下のおかしなところがあれば修正をお願いします。

Sub 指定位置から文字列削除()

Dim Moto As String
Dim KokoKara As Variant
Dim KokoMade As Variant

Dim i As Single
Dim SeiKei As String
Dim EndRow As Single

With Sheets("DATA")
EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To EndRow
If i = 1 Then
Nubering3 (i)
KokoKara = Application.InputBox(prompt:="＞何番目から？　数値を入力してください", Title:="指定位置（数値入力）", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
KokoMade = Application.InputBox(prompt:="何番目まで＞？　数値を入力してください", Title:="指定位置（数値入力）", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
End If

.Activate
Moto = Cells(i, "A")
SeiKei = Replace(Moto, Mid(Moto, KokoKara, KokoMade - KokoKara + 1), "")
.Range("B" & i) = SeiKei
Next i
End With
Sheets("Number").Range("A1:XX100").Clear
End Sub

Sub Nubering3(ByVal DataRow As Long)

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, WRow As Long, WColumn As Long
Dim uRows As Range, uRange As Range
Dim font1 As Font

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
WRow = 1: WColumn = 1
For j = 1 To Len(Ws1.Cells(DataRow, "A").Value)
Ws2.Cells(WRow, WColumn).Value = j
Ws2.Cells(WRow + 1, WColumn).Value = Mid(Ws1.Cells(DataRow, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, WColumn))
Set uRows = Union(uRows, Ws2.Rows(WRow))
If j Mod 40 = 0 Then
WRow = WRow + 3
WColumn = 1
Else
WColumn = WColumn + 1
End If
Next

'Numeling 大文字、中央揃え
uRows.HorizontalAlignment = xlCenter
uRows.Font.Bold = True
'フォントサイズ指定
uRows.Font.Size = 9

'分割文字中央揃え罫線外枠
uRange.HorizontalAlignment = xlCenter
uRange.Borders.LineStyle = xlContinuous
'フォントサイズ指定
'uRange.Font.Name = "HGP創英角ポップ体"
uRange.Font.Size = 9

'セル幅を見やすく
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
Sub B列をテキストファイル化()

Dim i As Single
Dim Ws1 As Worksheet
Dim EndRow As Single

Set Ws1 = Sheets("DATA")

EndRow = Ws1.Range("B1").CurrentRegion.Rows.Count
' MsgBox d

Open "C:\Users\Nubo\Desktop\Separate.txt" For Output As #1

For i = 1 To EndRow
Print #1, Cells(i, "B")
Next i

Close #1

Set Ws1 = Nothing

End Sub

回答No.3

kkkkkm

> Numberlingの文字サイズだけでなく
> 　罫線内の文字（下側の文字）も小さく表示したいのですが

行とセルと別れている理由が今わかりました。よく見ればわかる事でしたm(__)m
両方ともFont.Sizeを追加してください。

お礼

ありがとうございます。

２か所でフォントサイズの指定をしてうまく処理できました。

後だしジャンケンのようで恐縮ですが、
　今までは、指定箇所を抜き出しでしたが
　逆に指定箇所を削除はどうなるでしょうか　？

例えば、
　今日は、平成3年３月12日（月曜日）です。
の１４番目と18番目を指定して
　今日は、平成3年３月12日です。
とする場合です。

（抜き出す場合は、コードは出来たのですが
　削除の場合は、どうなるでしょうか？）

回答No.2

kkkkkm

> フォントサイズの指定はどこに挿入したら良いでしょうか？

最後の方で書式設定しているので合わせてそこに記載すると、あとから見たときにもわかりやすいと思います。

'Numeling 大文字、中央揃え
uRows.HorizontalAlignment = xlCenter
uRows.Font.Bold = True
uRows.Font.Size = 10

もしくは

'分割文字中央揃え罫線外枠
uRange.HorizontalAlignment = xlCenter
uRange.Borders.LineStyle = xlContinuous
uRange.Font.Size = 10

どちらか一方にFont.Sizeを追加してください。

書式設定を行とセルとで分けている理由が分からなかったので元のまま分けています。

補足

回答ありがとうございます。

Numberlingの文字サイズだけでなく
　罫線内の文字（下側の文字）も小さく表示したいのですが

　罫線内の文字（下側の文字）の設定は、どこに挿入しますか　？