Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

17499 / 76732

←次へ　｜　前へ→


	【64686】Re:指定する複数の値を抜き出したいのですが

Yuki - 10/3/8(月) 10:09 -


	引用なし

	パスワード

▼はるまきさん：
>　fd = "0123"　　 ' 検索値
>　は複数入力することはできますか？

Sub TEST()
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long
　　Dim v1　As Variant
　　Dim s1　As String
　　Dim s2　As String
　　Dim fd　As Variant
　　Dim sht As Worksheet
　　
　　fd = Array("000", "1234", "012", "013")
　　' 新しいシートの追加1番前へ
　　Set sht = Worksheets.Add(Before:=Worksheets(1))
　　' 手動で追加してある場合は
'　　Set sht = Worksheets(1)
'　　sht.Cells.ClearContents
　　sht.Columns("A:B").NumberFormatLocal = "@"
　　' 2番目のシートから検索
　　For i = 2 To Worksheets.Count
　　　　With Worksheets(i)
　　　　　　v1 = .Range("A1").CurrentRegion.Resize(, 1).Value
　　　　　　v1 = Application.Transpose(v1)
　　　　　　s1 = Join(v1, "")
　　　　　　For k = 0 To UBound(fd)
　　　　　　　　If Len(fd(k)) <= Len(s1) Then s2 = Left(s1, Len(fd(k)))
　　　　　　　　If StrComp(fd(k), s2, vbTextCompare) = 0 Then
　　　　　　　　　　' あったら新しいシートに
　　　　　　　　　　j = j + 1
　　　　　　　　　　sht.Cells(j, 1) = .Name
　　　　　　　　　　sht.Cells(j, 2) = s2
　　　　　　　　　　Exit For '123,1234と言うような検索値が無い場合は
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　Next
End Sub

1 hits

▼

【64668】指定する複数の値を抜き出したいのですが はるまき 10/3/3(水) 19:33