エクセルVBAで、特定文字から始まっていたら別シートに抽出したい

エクセルVBAを使い、特定文字から始まっているデータを別シートに抽出がしたいです。
他の方が質問していた内容を参考に、特定文字が含まれていたら抽出することは以下で可能でした。
特定文字から始まっている場合にするには、どこを修正すればよいでしょうか。

ド素人の質問ですみませんが、ご回答お願いいたします！


Sub データ抽出()
'----- 設定事項 ------------
Const OrgSh = "Sheet1" ' <--- 基データのシート名
Const PicSh = "Sheet2" ' <--- 抽出先シート名
Const TopAdd = "B2" '　　<--- 検索範囲の先頭(見出しを除く)
Const FindStr = "大阪府" ' < ---検索する文字列
'---------------------------
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Rng As Range
Dim First As String
Dim N As Long
Set Ws1 = Worksheets(OrgSh)
Set Ws2 = Worksheets(PicSh)
Ws2.Cells.ClearContents '抽出先シートをクリア
If Range(TopAdd).Row > 1 Then ' 見出し行があればコピー
　　Ws1.Range(TopAdd).Offset(-1).EntireRow.Copy Destination:=Ws2.Rows(1)
　　N = 1
End If
Set Rng = Ws1.Range(TopAdd).EntireColumn.Find(FindStr) '部分一致検索
If Not Rng Is Nothing Then
　　First = Rng.Address
　　Do
　　　　N = N + 1
　　　　Rng.EntireRow.Copy Destination:=Ws2.Rows(N)
　　　　Set Rng = Ws1.Range(TopAdd).EntireColumn.FindNext(Rng)
　　Loop Until Rng Is Nothing Or Rng.Address = First
End If
End Sub

No.3 ベストアンサー 回答者： SevenKnights 回答日時： 2021/07/11 13:45

すみません。

当方で使用したデータを使ってコードをテストした際に，設定事項を戻さずにアップしてしまいました。
Const TopAdd = "B2"
Const FindStr = "大阪府"
に戻して戴ければ幸いです。

この回答へのお礼

ありがとうございます！！できました。
また色々と教えてくださいm(__)m

お礼日時：2021/07/12 14:39

No.2 回答者： SevenKnights 回答日時： 2021/07/11 13:41

とてもよくできたマクロだと思います。

[1]シート名OrgSh，PicShが無い場合にエラーが出てしまうと思いますので，シートの有無を検査するコードを追加してみました。
[2]コードを挿入した個所が分かるようにコメント文字の「追加」を入れました。

Sub データ抽出()
'----- 設定事項 ------------
Const OrgSh = "Sheet1" ' <--- 基データのシート名
Const PicSh = "Sheet2" ' <--- 抽出先シート名
Const TopAdd = "D2" '　　<--- 検索範囲の先頭(見出しを除く)
Const FindStr = "内外" ' < ---検索する文字列
'---------------------------
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Rng As Range
Dim First As String
Dim N As Long
Dim FLAG As Boolean '追加
Call 追加(ThisWorkbook, OrgSh, FLAG) '追加
Select Case FLAG '追加
Case True '追加
Set Ws1 = Worksheets(OrgSh)
Call 追加(ThisWorkbook, PicSh, FLAG) '追加
Select Case FLAG '追加
Case True '追加
Set Ws2 = Worksheets(PicSh)
Ws2.Cells.ClearContents '抽出先シートをクリア
If Range(TopAdd).Row > 1 Then ' 見出し行があればコピー
Ws1.Range(TopAdd).Offset(-1).EntireRow.Copy Destination:=Ws2.Rows(1)
N = 1
End If
Set Rng = Ws1.Range(TopAdd).EntireColumn.Find(FindStr) '部分一致検索
If Not Rng Is Nothing Then
Select Case InStr(Rng, FindStr) '追加
Case 1 '追加
First = Rng.Address
Do
N = N + 1
Rng.EntireRow.Copy Destination:=Ws2.Rows(N)
Set Rng = Ws1.Range(TopAdd).EntireColumn.FindNext(Rng)
Loop Until Rng Is Nothing Or Rng.Address = First
Case Else '追加
End Select '追加
End If
Case False '追加
End Select '追加
Case False '追加
End Select '追加
End Sub
Sub 追加(W, SHEET_NAME, FLAG)
' シートの有無を検査します。
FLAG = False
For Each S In W.Sheets
Select Case S.Name
Case SHEET_NAME
FLAG = True
Exit For
Case Else
End Select
Next
End Sub

No.1 回答者： googoo900 回答日時： 2021/07/07 23:01

左端から指定した文字数を抜き出すLEFTと、文字の長さを返すLENを使えばよさそうです。

Left(対象語, Len(検索語))　を検索語と比較して一致したものを抽出すればよいとおもいます。