エクセルVBAの質問ですがここでよかったでしょうか？

質問

エクセルVBAの質問ですがここでよかったでしょうか？

Excel2000のマクロを組んでいます。

AutoFilterを使って選んだセルのうち、更にマウスで選択したセルを含むROWを
操作対象にしたいのですが、困っています。

ここにあるコードで概ね動くのですが、セルを一つだけ選択して実行すると
表示されている全てのセルが対象になってしまうようです。
複数選ぶと期待通りの動作になります。

.SpecialCells(xlVisible)を削除すると、この問題は解消するのですが、
AutoFilterで非表示にしたセルまで選択されてしまいます。

なにか良い解決法はないでしょうか？

Private Sub ボタン１_Click()
Dim CodeNumber As String
Dim PartNumber As String
Dim activeCells
Dim activeRow As Long
For Each activeCells In Selection.SpecialCells(xlVisible)
activeRow = activeCells.Row
If activeRow > 1 Then　'タイトルROWは選んでも無視する
CodeNumber = Cells(activeRow, 2).Value
PartNumber = Cells(activeRow, 3).Value
'色を変えて目印にする
Cells(activeRow, 2).Interior.ColorIndex = 34
Call ちょっとした処理(CodeNumber, CodeName)
End If
Next activeCells
End Sub

回答No.4

end-u · ベストアンサー

Intersectメソッドを使って、Loop対象範囲を最初にSetしてしまえば良いと思います。
ついでに見出し行も除く事ができます。

Dim CodeNumber　As String
Dim PartNumber　As String
Dim activeCells As Range
Dim activeRow　 As Long
Dim targetRng　 As Range '追加

On Error Resume Next
With Me.AutoFilter.Range
　　Set targetRng = Intersect(Selection, .SpecialCells(xlVisible), .Offset(1))
End With
On Error GoTo 0
If Not targetRng Is Nothing Then
　　With Me
　　　　For Each activeCells In targetRng
　　　　　　activeRow = activeCells.Row
　　　　　　CodeNumber = .Cells(activeRow, 2).Value
　　　　　　PartNumber = .Cells(activeRow, 3).Value
　　　　　　'色を変えて目印にする
　　　　　　.Cells(activeRow, 2).Interior.ColorIndex = 34
　　　　　　Call ちょっとした処理(CodeNumber, CodeName)
　　　　Next activeCells
　　End With
End If

Set targetRng = Nothing

On Error制御は、SelectionがRangeでなかった場合とAutoFilterかかってなかった場合の為。
シートモジュールに書かれている事前提に Me を使ってますが、
標準モジュールの場合は ActiveSheet などに変えてください。

お礼

ありがとうございます。

細かに手をいれて頂きError処理まで面倒みて頂いてありがたいです。

また宜しくお願いします。

回答No.3

nattocurry

追記：
activeRow=～～～
も Selection.Count が 1 かどうかで処理を変えます。

回答No.2

nattocurry

Selection.Count が 1 かどうかを調べて、処理を変えてはどうでしょうか？

私なら、
CodeNumber=～～～
PartNumber=～～～

の部分を、Selection.Count が 1 かどうかで処理を変えて、

Next の手前で、Selection.Count が 1 だったら、Exit For で強制的に Forループを抜けるようにします。

お礼

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

これは、考えたのですが、只でさえスパゲッティボールのプログラムなので
老化の始まった私のあたまでこれ以上複雑にするとBUGの元と敬遠してました。

また、よろしくお願いします。　m(_ _)m

回答No.1

myRange

（条件）
表の開始セル：　Ａ１
見出し行＿＿：　１行目
データ行＿＿：　２行目以降～

'-----------------------------------------------
Private Sub ボタン１_Click()
　Dim CodeNumber As String
　Dim PartNumber As String
　Dim ActiveRow As Long

'フィルターで抽出された範囲の取得

　Dim myRange As Range
　Set myRange = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)

'フィルターで抽出された範囲外は無視

　If Intersect(ActiveCell, myRange) Is Nothing Then Exit Sub

'１行目の見出し行は無視

　If ActiveCell.Row = 1 Then Exit Sub

　　　　ActiveRow = ActiveCell.Row
　　　　CodeNumber = Cells(ActiveRow, 2).Value
　　　　PartNumber = Cells(ActiveRow, 3).Value
　　　　Cells(ActiveRow, 2).Interior.ColorIndex = 34

　　　　Call ちょっとした処理(CodeNumber, ●CodeName)
End Sub
'----------------------------------------------

今回の件とは関係ないですが、
最後の、"ちょっとした処理"の引数●CodeNameは宣言されてないですね。
以上です。

お礼

明快な回答ありがとうございました。

ついでのDEBUGまでして頂いて（＾＾；；；ありがとうございます。　m(_ _)m

補足

Intersectを使って希望のプログラムとなりました。
For Each　ループを使ってこれでばっちりでした。

Private Sub ボタン１_Click()

Dim CodeNumber As String
Dim PartNumber As String

Dim activeCells
Dim activeRow As Long
Dim myRange As Range

Set myRange = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)

For Each activeCells In Intersect(Selection, myRange)

activeRow = activeCells.Row

If activeRow > 1 Then　' タイトル行は除外

CodeNumber = Cells(activeRow, 2).Value
PartNumber = Cells(activeRow, 3).Value

'色を変える

Cells(activeRow, 2).Interior.ColorIndex = 34

Call ちょっとした処理(CodeNumber, PartNumber)

End If

Next activeCells

End Sub