Numberシートにナンバリングして表示したい

質問

EXCEL(VBA)で
DATAシートのA2セル以下にターゲットの文字列が入っています。
　（ターゲットの文字列は、複数の場合もあります。）

この文字列の左からの位置を数えた数値を視覚的に知るために
　Numberシートにナンバリングして表示したいのですが
　VBAで処理できますか　？

言葉で解説するのが難しいので
　参照画像を参照してください。
--------------
半角、全角はスペースを含めて同じ1文字とします。

参照画像
https://imgur.com/ktTxZuP

回答No.6

kkkkkm · ベストアンサー

> DATAシートを表示した状態では、Sub Nubering3()でエラーが出ます。

ごめんなさい。Ws2指定してなかったところが数か所ありましたので以下で試してみてください。
他も気になったところ変更しました。

If Ws2.Range("A1").Value = "" Then
↓
If Ws2.Range("A1").Value = "" And WRow = 2 Then

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

Set Ws1 = Nothing
Set Ws2 = Nothing
Set uRows = Nothing
Set uRange = Nothing
End Sub

お礼

No3の修正（気になった点も含めて）ありがとうございます。

修正でエラー無く完動しました。

uRows、uRangeと見たこと無いコードが出てきたので
　WEB検索して見ましたがヒットしませんでした。

両者の解説したWEB等あれば紹介ください。

回答No.7

kkkkkm

> uRows、uRangeと見たこと無いコード

両方とも変数です。Unionされた行とセルなのでURowsとURangeとかにしただけでたいした意味はありません。Dim で指定しているのは全て変数です。変数名考えるの面倒なので殆どは適当です。

補足

失礼しました。
　ピントはずれな質問でお手数をおかけしました。

Dim の設定のところ、改訂版でチェックしていませんでした。
（DIMの設定が追加されていたのを見逃していました。）

これでやりたいことは、出来るようになったので解決とします。
お世話になりました。

回答No.5

SI299792

関数と条件付き書式でできますが。

A1: =IF(A2="","",COLUMN())
A2: =MID(INDEX(DATA!$A:$A,ROW()/2+1),COLUMN(),1)

条件付き書式、新しいルール、
数式を使用して、書式設定するセルを決定
次の数式を満たす場合に値を書式設定、
=A1>""
書式、罫線、外枠、OK、OK

前にも書きましたが、条件が変わったのなら再質問すべきです。
https://okwave.jp/qa/q9852905.html
貴殿がマナーを守らない人だという事を忘れていました。
回答したことを後悔していますが、残念ながらここでは回答を取り消せません。
今後２度と回答しないように気を付けます。

回答No.4

kkkkkm

No3の訂正です。

Nubering3()でSet uRowsの位置が違いました。

For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(WRow, j).Value = j
Set uRows = Union(uRows, Ws2.Rows(WRow))
Ws2.Cells(WRow + 1, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, j))
Next

↓

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

補足

ありがとうございます。

３つのSub()をテストしてみました。
(No3の訂正のコードを利用)

Numberシートを表示した状態では、3個共に完動しますが、
DATAシートを表示した状態では、Sub Nubering3()でエラーが出ます。

　　実行時エラー'1004':
　　’Union'メソッドは失敗しました：’_Goobal’オブゼクト

　　 Set uRows = Union(uRows, Ws2.Rows(WRow))

-------------------

回答No.3

kkkkkm

3個思いついたので3個とも出してみます。動作時の画面表示をオフにしました。

行を毎回計算します。行関係が変わった場合計算式を変更する必要がありそうです。
↓
Sub Nubering1()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")

'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア）
Ws2.Range("A1:XX100").Clear

Application.ScreenUpdating = False

For i = 2 To Ws1.Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells((i - 1) * 2 - 1, j).Value = j
''Numeling 大文字、中央揃え
Ws2.Cells((i - 1) * 2 - 1, j).HorizontalAlignment = xlCenter
Ws2.Cells((i - 1) * 2 - 1, j).Font.Bold = True

Ws2.Cells(i * 2 - 2, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Ws2.Cells(i * 2 - 2, j).HorizontalAlignment = xlCenter '中央揃え
Ws2.Cells(i * 2 - 2, j).Borders.LineStyle = xlContinuous '罫線外枠
Next
Next i

Ws2.Range("A1:xx100").ColumnWidth = 3 '
Application.ScreenUpdating = True
Set Ws1 = Nothing
Set Ws2 = Nothing
End Sub

NumberシートのA列最終行を探して行を指定します。
↓
Sub Nubering2()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long, WRow As Long

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")

'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 Range("A1").Value = "" Then
WRow = 1
End If
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(WRow, j).Value = j
''Numeling 大文字、中央揃え
Ws2.Cells(WRow, j).HorizontalAlignment = xlCenter
Ws2.Cells(WRow, j).Font.Bold = True

Ws2.Cells(WRow + 1, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Ws2.Cells(WRow + 1, j).HorizontalAlignment = xlCenter '中央揃え
Ws2.Cells(WRow + 1, j).Borders.LineStyle = xlContinuous '罫線外枠
Next
Next i

Ws2.Range("A1:xx100").ColumnWidth = 3 '

Application.ScreenUpdating = True

Set Ws1 = Nothing
Set Ws2 = Nothing
End Sub

Nubering2()で毎回書式設定していたのをUnion利用して最後に一括で処理します。これが早いかもしれません。
↓
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 = Rows(1)
Set uRange = 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 Range("A1").Value = "" Then
WRow = 1
End If
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(WRow, j).Value = j
Set uRows = Union(uRows, Ws2.Rows(WRow))
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

Set Ws1 = Nothing
Set Ws2 = Nothing
Set uRows = Nothing
Set uRange = Nothing
End Sub

回答No.2

kkkkkm

以下のコードで試してみてください。

Numberシートのクリア範囲は適当ですので適宜変更してください。
Numberシートの1行目の連番も入れてます。もとも入れている場合は
Ws2.Cells(1, j).Value = j
を無効にしてください。

Sub Test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")

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

For i = 2 To Ws1.Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(1, j).Value = j
Ws2.Cells(i, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Next
Next i
Set Ws1 = Nothing
Set Ws2 = Nothing
End Sub

お礼

kkkkmさん、今回も回答頂きありがとうございます。

アドバイスいただいたコードを一部改ざんして試してみたのですが
参考図のようにターゲットの文字列ごとにナンバリングしたいのですが
　　どのように修正すれば良いですか　？

参考図
https://imgur.com/gZJxSzL

-------------------------------　以下、改ざんコード
Sub Nubering()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim i As Long, j As Long

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")

'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア）
Ws2.Range("A1:XX100").Clear

For i = 2 To Ws1.Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Len(Ws1.Cells(i, "A").Value)
Ws2.Cells(1, j).Value = j
Ws2.Cells(i, j).Value = Mid(Ws1.Cells(i, "A").Value, j, 1)
Ws2.Cells(i, j).HorizontalAlignment = xlCenter '中央揃え
Ws2.Cells(i, j).Borders.LineStyle = xlContinuous '罫線外枠
Next
Next i

'Numeling 大文字、中央揃え
Ws2.Rows("1:1").HorizontalAlignment = xlCenter
Ws2.Rows("1:1").Font.Bold = True
'セル幅を見やすく
Ws2.Range("A1:xx100").ColumnWidth = 3 '

Set Ws1 = Nothing
Set Ws2 = Nothing
End Sub

回答No.1

SI299792

これなら、VBA を使わなくても、
A1: 1
A2: =MID(Data!A2,A$1,1)
A2を下へコピペ。
纏めて右へコピペ。
でいいのでは。

お礼

SI299792さん、回答ありがとうございます。

だんだん欲が出て
　処理が複雑になっていきそうなので関数だけでは処理が難しいそうです。