特定のセルの文字数を数え、奇数、偶数でＩＦ分を作成

シート1、2の、Cells(8, 40)、Cells(17, 40)、Cells(26, 40)に入力される文字
例、Ａ622-4、Ａ1211-3とかの文字数が偶数なら、Ａの次の1文字、6を指数に、
奇数ならＡの次の2文字、12を指数に置き換えるコードを作成したいです。
　現在はユーザーフォームでマクロ1、2で切り替えるようにしていますが。
このユーザーフォームを無くして、Cells(8, 40)、Cells(17, 40)、Cells(26, 40)
の文字数が奇数、偶数で処理できないでしょうか？
よろしくお願いします。

Sub Macro1()
For Each XX In Sheets("Sheet1").Cells(8, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet1").Cells(17, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet1").Cells(26, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(8, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(17, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(26, 40)
If XX.Text Like "[A-Z]#*" Then
XX.Characters(Start:=2, Length:=1).Font.Superscript = True
End If
Next
End Sub

Sub Macro2()
For Each XX In Sheets("Sheet1").Cells(8, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet1").Cells(17, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet1").Cells(26, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(8, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(17, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
For Each XX In Sheets("Sheet2").Cells(26, 40)
If XX.Text Like "[A-Z]##*" Then
XX.Characters(Start:=2, Length:=2).Font.Superscript = True
End If
Next
End Sub

No.2 ベストアンサー 回答者： rabbit_9999 回答日時： 2020/05/14 17:04

こんな感じでしょうか。

Sub Macro4()

Dim cellList As Variant
Dim wStr As String
Dim suLen As Integer

cellList = Array( _
Sheets("Sheet1").Cells(8, 40), _
Sheets("Sheet1").Cells(17, 40), _
Sheets("Sheet1").Cells(26, 40), _
Sheets("Sheet2").Cells(8, 40), _
Sheets("Sheet2").Cells(17, 40), _
Sheets("Sheet2").Cells(26, 40) _
)

For Each cell In cellList
cell.Font.Superscript = False

wStr = cell.Value
If Len(wStr) Mod 2 = 0 Then
suLen = 1
Else
suLen = 2
End If
cell.Characters(Start:=2, Length:=suLen).Font.Superscript = True

Next

End Sub

既にNo.1さんが指摘されていますが、Lenを使って文字数を取って、それを2で割って奇数か偶数かチェック。
同じ事をやっているので、セルを配列に入れてLoop処理。
あと、念のため一度全部を「Superscript = False」にするのも必要かと。

この回答へのお礼

ご回答ありがとうございます。
早速、試してみたところうまくできました。
助かります、あと、一つ一つのコードを
理解し自分でも作れるようにしたいと思います。

お礼日時：2020/05/15 08:29

No.1 回答者： fujillin 回答日時： 2020/05/14 16:53

こんにちは

＞の文字数が奇数、偶数で処理できないでしょうか？
そのまま判断すれば可能と思います。
セルの文字数はLen関数で得られますので、
　Len(Cells(x, y).Text) Mod 2
が１なら奇数文字、０なら偶数文字とすれば宜しいでしょう。

余談ですが…
ざっと見たところ、各セルに対して同じ処理を繰り返しているようですので、セル位置を変数にして、シートと併せてループするような記述にすれば、概ね１/６程度の記述にできるのではないかと思われます。

この回答へのお礼

早速、ご回答ありがとうございます。
ご指摘の、Len(Cells(x, y).Text) Mod 2を入れてやってみます。
あと、ループにするのも何とか挑戦してみたいと
思います。

お礼日時：2020/05/14 17:22