| |
▼［名前なし］alikui さん：
なんとなく、まだ要件を誤解しているような気がします。
一応、こちらの解釈によるコードを以下にアップしますが、
こちらの解釈とコード(Sample1)
・インプットボックスで、【抽出文字列】を指定。
・その指定文字列でフィルタリング
・抽出されたもののＢ列のセルに、特定の文字をセット。（以下のコードでは、"○")
・これを、インプットボックスでキャンセルボタンが押されるまで繰り返す。
でも、もしかしたら
・手作業でフィルタ抽出し、その後、マクロ実行
・マクロでは、Ｂ列に入力する文字列を指定させて
・それを抽出されたデータのＢ列のセルに転記して終わり。
この作業を繰り返す？もし、そうであれば、Sample2
Sub Sample1()
Dim myWord As String
Dim sh As Worksheet
Dim myA As Range, myB As Range, myC As Range, myV As Range
Dim vC As Range
Set sh = Sheets("Sheet1") '対象のシート名
If Not sh.AutoFilterMode Then
MsgBox "フィルターが設定されていません"
Else
If sh.FilterMode Then sh.ShowAllData
Set myA = sh.AutoFilter.Range
Set myB = Intersect(myA, myA.Offset(1))
If myB Is Nothing Then
MsgBox "データがリストに登録されていません"
Else
Do
myWord = InputBox("検索文字を指定してください")
If myWord = Empty Then Exit Do 'キャンセル
myA.AutoFilter 1, myWord
Set myV = Nothing
On Error Resume Next
Set myV = myB.Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not myV Is Nothing Then
For Each myC In myV
myC.Offset(, 1).Value = "○"
Next
Else
MsgBox "抽出されませんでした"
End If
ActiveSheet.ShowAllData
Loop
End If
End If
Set myA = Nothing
Set myB = Nothing
Set myC = Nothing
Set myV = Nothing
Set sh = Nothing
End Sub
Sub Sample2()
Dim myWord As String
Dim sh As Worksheet
Dim myA As Range, myB As Range, myC As Range, myV As Range
Dim vC As Range
Set sh = Sheets("Sheet1") '対象のシート名
If Not sh.AutoFilterMode Then
MsgBox "フィルターが設定されていません"
Else
Set myA = sh.AutoFilter.Range
Set myB = Intersect(myA, myA.Offset(1))
If myB Is Nothing Then
MsgBox "データがリストに登録されていません"
Else
If Not sh.FilterMode Then
MsgBox "フィルタリングされていません"
Else
Set myV = Nothing
On Error Resume Next
Set myV = myB.Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not myV Is Nothing Then
myWord = InputBox("セットする文字列を指定してください")
If myWord <> Empty Then 'キャンセルではない
For Each myC In myV
myC.Offset(, 1).Value = myWord
Next
End If
Else
MsgBox "抽出されていませんよ"
End If
ActiveSheet.ShowAllData
End If
End If
End If
Set myA = Nothing
Set myB = Nothing
Set myC = Nothing
Set myV = Nothing
Set sh = Nothing
End Sub
|
|
UO3
- 11/6/9(木) 13:54 -
