VBA カッコの有無で処理を分岐

質問

フォルダー名の変名をマクロで行っています。

変名前のフォルダー名に西暦が含まれるケースで
　カッコ付きとカッコ無しがあります。

例えば、
　　（1995）と1995
　　　　カッコは半角の場合がほとんどですが、稀に全角の場合も存在します。

カッコの有無でIF文などで処理を分岐したいのですが
　　どのように判別コード（式）になりますか　？

回答No.9

kkkkkm · ベストアンサー

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
goto sonzai
else
'---末尾に3枚のシートを追加し、名前を付ける
End If
Next Ws

sonzai:

一番最初にソート前が見つかればGotoですがそうとは限らないのでソート前に出会うまではElseにいきます。
結果既にシートがある場合エラーになります。

最後まで見ることにしてソート前が出たらGoTo

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
GoTo sonzai
End If
Next Ws
'---末尾に3枚のシートを追加し、名前を付ける
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート前"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sub 項目のみ"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート後"
sonzai:
Set Ws2 = Sheets("ソート前")
Set Ws3 = Sheets("Sub 項目のみ")
Set Ws4 = Sheets("ソート後")

GoToは使わない方がいいという意見を多く聞きますので
GoToを使わずに無いシートだけ作成することも考えた場合は、以下のような感じでも（もっといいやり方があるかもしれません)

Dim flg As Boolean, Wsflg1 As Boolean, Wsflg2 As Boolean, Wsflg3 As Boolean
Dim Ws As Worksheet

Wsflg1 = False: Wsflg2 = False: Wsflg3 = False

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
Wsflg1 = True
ElseIf Ws.Name = "Sub 項目のみ" Then
Wsflg2 = True
ElseIf Ws.Name = "ソート後" Then
Wsflg3 = True
End If
Next

If Wsflg1 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート前"
End If
If Wsflg2 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sub 項目のみ"
End If
If Wsflg3 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート後"
End If

お礼

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

>Next Wsの位置が違います

いつもの早とちりの失敗で失礼しました。

Gotoを使わないFlagを利用したコードの方が
　3個の作成シートの存在をチェックして見た目に分かりやすいので
　こちらを利用する事にしました。

今回もやりたいことがコード化できてスッキリしました。
最後までお付き合いいただき改めてお礼申し上げます。

補足

コードをありがとうございます。

提示頂いたコードを検証しました。

コード①は、
　1回目に3個のシートを作成後、2回めに起動した時点で
　以下でエラーが出ます。

　　　ActiveSheet.Name = "ソート前"

　　この名前は既に使用されています。
　　別の名前を入力して下さい。

　Goto　sonzai：　に飛んでいません。

コード②は、
　　正常に最後まで完走して処理出来ました。

　　3つのシート毎に存在を確認するようにしないエラーが出るようです。
----------------------------------------------------------
①
Sub コードのソート()
Dim Ws As Worksheet
Dim Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Dim i As Long, j As Long, k As Long
Dim flg As Boolean

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
GoTo sonzai
End If
'---末尾に3枚のシートを追加し、名前を付ける
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート前"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sub 項目のみ"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート後"
sonzai:
Set Ws2 = Sheets("ソート前")
Set Ws3 = Sheets("Sub 項目のみ")
Set Ws4 = Sheets("ソート後")
Next Ws

-------------------------------------------------------------------------------
②
Sub コードのソート()
Dim Ws As Worksheet
Dim Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Dim i As Long, j As Long, k As Long
Dim flg As Boolean
Dim Wsflg1 As Boolean, Wsflg2 As Boolean, Wsflg3 As Boolean

Wsflg1 = False: Wsflg2 = False: Wsflg3 = False

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
Wsflg1 = True
ElseIf Ws.Name = "Sub 項目のみ" Then
Wsflg2 = True
ElseIf Ws.Name = "ソート後" Then
Wsflg3 = True
End If
Next

If Wsflg1 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート前"
End If

If Wsflg2 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sub 項目のみ"
End If

If Wsflg3 = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート後"
End If

Set Ws2 = Sheets("ソート前")
Set Ws3 = Sheets("Sub 項目のみ")
Set Ws4 = Sheets("ソート後")

回答No.10

kkkkkm

> コード①は、
> 　1回目に3個のシートを作成後、2回めに起動した時点で
> 　以下でエラーが出ます。

Next Wsの位置が違います

回答No.8

kkkkkm

> 手動コピペの実施用のメッセージを一度出して、プログラムを停止させて
> コピペが終了したらコードを進行させても良いように「Y」などを入れる
> 過程が必要になります。

一時停止ではなく一旦終了して同じコードを再度実行するという事で解決します。

シートの追加の所で既に同一シート名があれば追加しないようにします。
現状では同じシート名があるとエラーになります。

次に

j = 1
For i = 1 To Ws2.Cells(Rows.Count, "A").End(xlUp).Row

のループの前に（一番最初のループです)

If Ws2.Range("A1").Value = "" Then
Ws2.Activate
Ws2.Range("A1").Select
MsgBox "コードを貼り付けてください", vbInformation
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
Exit Sub
End If

と入れておきます。

これで、最初に実行したときはシートが作成され、Ws2のA1が未入力なのでメッセージが出て終了します。
コードをコピペして再度実行するとシートは既にあるのでそこはスルーされ、Ws2のA1にはコードがあるので上記のメッセージ部分もスルーされて、以降のコードが実行されます。

お礼

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

>シートの追加の所で既に同一シート名があれば追加しないようにします。

以下のように最初にシートの存在をチェックするようにしましたが
goto が機能しません。
初歩的な事ですがなぜでしょうか　？

Sub コードのソート()
Dim Ws As Worksheet
Dim Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Dim i As Long, j As Long, k As Long
Dim flg As Boolean

For Each Ws In Worksheets
If Ws.Name = "ソート前" Then
goto sonzai
else
'---末尾に3枚のシートを追加し、名前を付ける
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート前"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sub 項目のみ"
Worksheets().Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ソート後"

Set Ws2 = Sheets("ソート前")
Set Ws3 = Sheets("Sub 項目のみ")
Set Ws4 = Sheets("ソート後")
End If
Next Ws

sonzai:

If Ws2.Range("A1").Value = "" Then
Ws2.Activate
Ws2.Range("A1").Select
MsgBox "ソート前のコードをソート前に貼り付けてください", vbInformation
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
Exit Sub
End If

j = 1
For i = 1 To Ws2.Cells(Rows.Count, "A").End(xlUp).row
If Ws2.Cells(i, "A").Value Like "Sub*" Or _
Ws2.Cells(i, "A").Value Like "Private Sub*" Or _
Ws2.Cells(i, "A").Value Like "Public Sub*" Then
Ws3.Cells(j, "A").Value = Ws2.Cells(i, "A").Value
j = j + 1
End If
Next
With Ws3
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending
.Sort.SetRange .Range(.Cells(1, "A"), .Cells(Rows.Count, "A").End(xlUp))
.Sort.Apply
k = 1
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).row
j = 1
flg = False
For j = 1 To Ws2.Cells(Rows.Count, "A").End(xlUp).row
If Ws2.Cells(j, "A").Value = .Cells(i, "A").Value Or flg = True Then
If Ws2.Cells(j, "A").PrefixCharacter <> "" Then
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").PrefixCharacter & "'" & Ws2.Cells(j, "A").Value
Else
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").Value
End If
flg = True
k = k + 1
If Ws2.Cells(j, "A").Value Like "End Sub*" Then
flg = False
k = k + 1
Exit For
End If
End If
Next
Next
End With
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
End Sub

回答No.7

kkkkkm

> Module1にSheet2に貼り付けたマクロが追加されました。

これはあり得ない現象だと思います。
Module1などを操作するには以下のサイトで説明があるセキュリティ設定とコードが必要です。
EXCEL VBAメモ - xlsmファイル中のマクロの書き換え
https://hake.hatenablog.com/entry/20170812/p1

> Sheet4に並び替えたコードが出来上がるはずですが、何も書き込みがありません。

マクロを実行してSheet3のA列にSub〇〇の部分だけの一覧ができていなければSheet4に何も出ないと思います。

たとえば以下のコードをSheet2にコピペしたときに

Sub T()
a = B
c = D
End Sub

A1にSub T()
A2にa = B
A3にc = D
A4にEnd Sub

となっているでしょうか

あと今気が付きましたが行頭にコメントの印「'」がある場合セルに入れてコピペで戻したときに「'」が外れますので

　　　　　　　　If Ws2.Cells(j, "A").Value = .Cells(i, "A").Value Or flg = True Then
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").Value
flg = True

を

If Ws2.Cells(j, "A").Value = .Cells(i, "A").Value Or flg = True Then
If Ws2.Cells(j, "A").PrefixCharacter <> "" Then
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").PrefixCharacter & "'" & Ws2.Cells(j, "A").Value
Else
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").Value
End If
flg = True

に変更すれば外れなくなります。

補足

>これはあり得ない現象だと思います。

回答を受けて、もう一度
　最初から１），２），３）の手順で作業を行いました。

結果、
　ソートされたコードがSheet4に作成されました。

Module1には同じ名前のコードが2個ずつ存在する状態になったのは、

　多分私がコードをコピーした時に誤ってModule1内で貼り付けボタンクリックした事が原因だと思います。
（提示いただいたコードに原因が有るような書き込み、失礼しました。お詫びいたします。）

コードを汎用にしたいので少し修正を始めました。

ソートするには3つのシートが必要なので以下のコードを最初に追加しました。

'---末尾に3枚のシートを追加し、名前を付ける
Worksheets().Add After := Worksheets(Worksheets).Count
ActiveSheet.name="ソート前"
Worksheets().Add After := Worksheets(Worksheets).Count
ActiveSheet.name="Sub 項目のみ"
Worksheets().Add After := Worksheets(Worksheets).Count
ActiveSheet.name="ソート後"

Set Ws2 = Sheets("ソート前")
Set Ws3 = Sheets("Sub 項目のみ")
Set Ws4 = Sheets("ソート後")

で次に、「「ソート前」のシートにModule1のコードを手動でA1から貼りつける」工程が必要ですが
ここをマクロで出来ないかと思い”マクロの記録”でトレースしてコードを作成しましたが
以下のようなコードが作成されるのでマクロで自動化が出来ないと判断しました。
（多分、kkkkkmさんが手動で貼り付けなさいと解説したのは自動化出来ないので
　　手動と記載されたのだと思いました。）

----------------------
Sub コードコピー()
'
' コードコピー Macro
'
'
Sheets.Add After:=ActiveSheet
ActiveSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
DisplayAsIcon:=False, NoHTMLFormatting:=True
End Sub
----------------------
で手動で貼り付けるには「Set Ws4 = Sheets("ソート後")」の後に
手動コピペの実施用のメッセージを一度出して、プログラムを停止させて
コピペが終了したらコードを進行させても良いように「Y」などを入れる
過程が必要になります。

これは、どのように処理すれば良いでしょうか　？

回答No.6

kkkkkm

> そして、最後にModule2を作成して番号順に保存していたファイルを書き戻す事は可能でしょうか　？

凄く単純にしか考えていないコードですが（手慰み程度と考えてください)
Sheet2にモジュールのコードを手動でA1から貼り付けます。
それで実行するとSheet4に並び替えたコードが出来上がりますのでモジュールに手動でコピペするというものです。

SubのプロシージャだけですのでFunctionとかは追加が必要です。
End Subと次のSubの間のコメント行などは取り込みません。

Sub Test()
Dim Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Dim i As Long, j As Long, k As Long
Dim flg As Boolean

Set Ws2 = Sheets("Sheet2")
Set Ws3 = Sheets("Sheet3")
Set Ws4 = Sheets("Sheet4")

j = 1
For i = 1 To Ws2.Cells(Rows.Count, "A").End(xlUp).Row
If Ws2.Cells(i, "A").Value Like "Sub*" Or _
Ws2.Cells(i, "A").Value Like "Private Sub*" Or _
Ws2.Cells(i, "A").Value Like "Public Sub*" Then
Ws3.Cells(j, "A").Value = Ws2.Cells(i, "A").Value
j = j + 1
End If
Next
With Ws3
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending
.Sort.SetRange .Range(.Cells(1, "A"), .Cells(Rows.Count, "A").End(xlUp))
.Sort.Apply
k = 1
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
j = 1
flg = False
For j = 1 To Ws2.Cells(Rows.Count, "A").End(xlUp).Row
If Ws2.Cells(j, "A").Value = .Cells(i, "A").Value Or flg = True Then
Ws4.Cells(k, "A").Value = Ws2.Cells(j, "A").Value
flg = True
k = k + 1
If Ws2.Cells(j, "A").Value Like "End Sub*" Then
flg = False
k = k + 1
Exit For
End If
End If
Next
Next
End With
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
End Sub

補足

コードの提示、感謝します。

コードの検証を行いました。
以下、作動の手順です。

１）標準モジュールのModule1の全てのコードを手動でSheet2のA1から貼り付けました。
２）提示いただいたコード（Sub Test())を標準モジュールのModule1の最後に追加しました。
３）Sub Test()を実行しました。

結果、

Sheet4に並び替えたコードが出来上がるはずですが、何も書き込みがありません。
その代わり、
　　Module1にSheet2に貼り付けたマクロが追加されました。
　　（つまり、Module1には同じ名前のコードが2個ずつ存在するようになりました。
　　　　　　但し、Sub Test（）は1個のみ）

手順がおかしいのでしょうか　？

回答No.5

kkkkkm

> 意味が伝わら無いので言い換えると、

No3は言葉足らずな回答でした。
もし私がやるとしても、モジュール内でコピペして順番を入れ替えるか、新しい標準モジュールを作成してそちらに順番にコピペするとかします。（ただ、単にコピペでは回答にならないと思ったので除外して)
もしかしたらコピペ以外の簡単な方法があるのかもしれませんが、私にはちょっとわかりません。
の「分からない」という部分だけを回答しましたが、分からないだけでは何が分からないのかがはっきりしない回答になってしまいましたすみません。

お礼

>No3は言葉足らずな回答でした。

No.5の回答を得て意味が分かりました。

私の考える方法以外のスマートな方法がありそうなので質問しましたが
簡単な機能は無いようですね。

>新しい標準モジュールを作成してそちらに順番にコピペするとかします。

No5の回答を得て少し考えたのですが、

標準モジュールのModule1を全てサーチして
　Subの中に数字文字（①など）が有る場合
　①Sub~End Subまでを一つの塊①_Subのファイル名で適当な場所に保存。
　②以降が存在する場合は、②_Sub,③_Subと順次保存して行きます。
　（名無しの場合もNon1＿Subなど適当なファイル名で保存）

　そして、最後にModule2を作成して番号順に保存していたファイルを書き戻す事は可能でしょうか　？
　（結果として手動でコピペする動作と同じになります。）

回答No.4

imogasi

・変数に文、問題のフォルダ名の文字列を入れる。
例　Texｔ=・・・
・半角だろうと思いますが、年のため半角に変換して、統一して考える
・ＦｏｒＮｅｘｔで１文字づつＭＩＤ関数で捉えて、括弧半角を判別。
・Instr関数でＴｅｘｔを調べて、あれば文字位置を知る
・正規表現Ｒｅｇｅｘｐを使う
ーー
・ファイル・フォルダ名を扱うソフトを使う。
・その他　？
こういうやり方をすぐ思い付かないとだめ。
Instr関数などがよいのでは。
後は、本の野関係箇所やＷＥＢ記事を探せば仕舞。

回答No.3

kkkkkm

> 　　標準モジュールでソートされていないコードを
> 　　クイックアクセスツールバーのように
> 　　　　ソートして順番にできないでしょうか　？

うーん、ちょっと分からないです。

補足

>うーん、ちょっと分からないです。

意味が伝わら無いので言い換えると、

標準モジュールでは、上から⑤、番号なし、③、①、②、④の順番に配置されています。
これを、①、②、③、④、⑤、番号なし　のようにソートした順番に並び替えたい。

テキストエディターを開いて
最初に標準モジュールから①のSUBをコピペして
次に②のSUBをコピペ、③のコピペと順番に再配置して
テキストエディターでは、①、②、③、④、⑤、番号なしの
順番に配置されたコードを

標準モジュールに以前のコードを削除の上、
貼り直しすればソートされた順番になりますが

それ以外の方法がありそうなので相談しました。

回答No.2

kkkkkm

StrConvで検索対象を半角にして
たとえば
If StrConv(Cells(i, "A").Value, vbNarrow) Like "*(*" Then
や
If InStr(StrConv(Cells(i, "A").Value, vbNarrow), "(") Then
などで試してみてください。

お礼

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

教えてもらったコードを参考にして下記で上手く処理できました。
　　If StrConv(Cells(5, "B").Value, vbNarrow) Like "*(*" Then

直接今回の質問には、無関係なのですがご存知なら教えて下さい。

私は、先駆者の皆様が既にWEBで紹介されているコードなどを参考に
　それを組み合わせてマクロで処理する事が多いのですが、
　今回の場合は、以下の５つのパート（①~⑤）を組み合わせて処理しました。

コードを作成する順番がスムーズに行かなかったので
　　標準モジュールでは以下のように上から
　　　⑤、③、①、②、④　とSubはソートされていません。
　　　（⑤と③の間には、参考のため残した番号なしのSubも存在）

マクロを実施するためにクイックアクセスツールバーにある
　マクロを呼び出すと添付画像のようにマクロ名がソートされて
　①~⑤と順番に表示されます。

https://imgur.com/3WMRtlz

そこで質問ですが、
　　標準モジュールでソートされていないコードを
　　クイックアクセスツールバーのように
　　　　ソートして順番にできないでしょうか　？

勿論、一回全てのコードをテキストエディターに読み込んで
　①から順番にコピペで順番を入れ替えた結果を
　標準モジュールに新しく書き戻すことも出来るでしょうが
　もう少しスマートな方法があれば紹介下さい。

Sub ⑤フォルダー名の変更()

End Sub
’-------------------------------------------------------
Sub カッコの内の文字列を抜き出す()

End Sub
’-------------------------------------------------------
Sub ③数値のみ抜き出し()

End Sub
’-------------------------------------------------------
Sub ①フォルダー名の変更()

Call ②西暦部分を削除して記載
Call ③数値のみ抜き出し
Call ④整形
Call ⑤フォルダー名の変更

End Sub
’-------------------------------------------------------
Sub ②西暦部分を削除して記載()

End Sub
’-------------------------------------------------------
Sub ④整形()

End Sub

回答No.1

bardfish

VBAで関数を作るのでしょうか？それともセルに記述する関数で日下か？

私の場合と前置きしておきますが、考え方だけ。

まず、全角半角混じりなら一旦全て半角にします。その後で(もしくは)か含まれているかチェックしたうえでカッコ文字を削除します。
事前チェックしなくてもカッコ文字が含まれている場合のみ指定した文字に置き換える関数があるのでそれを使えば一回で完結。

セルに式を記述する場合は一旦別のセルに変換結果を転記してそちらを利用する方法がいいと思います。
具体的な式やセルに記述手背切る関数がどんなものがあるかは検索して探してください。VBAならInStr()とかMid()関数やVB.netならToUpper()とかReplace()など同じ結果を導き出す場合でもいくつか関数が用意されていたりしますので･･･

例）excel 関数 半角変換

お礼

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

>VBAで関数を作るのでしょうか

すいません。
　「判別コード（式）」と誤解を招く書き込みでした。

マクロのコードを知りたいわけで関数ではありません。

コードは、kkkkkmさんのコードで処理できました。