• ベストアンサー

Excel VBA: 複数行を選択したらエラーにしたい?

お世話になります。 複数行にわたって選択しているときに実行するとエラーメッセージを出したいとします。現状では、 If Selection.Rows.Count <> 1 Then subMsgBox "You are selecting two or more rows" Exit Sub End If としていますが、これではドラッグで連続した行を選択している場合には正しくエラーになりますが、Ctrlクリックでポンポンと飛ばし飛ばしクリックしている場合はエラーになりません。 If Selection.Cells.Count <> 1 Then だと同じ行の複数個所を選んだ場合もエラーになってしまいます。 If Selection.Cells.EntireRow.Count <> 1 Then If Selection.Cells.EntireRow.Rows.Count <> 1 Then でもCtrl+クリックの場合にダメです。 どうしたらいいでしょうか。 よろしくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

'MSDNライブラリのApplication.SelectionがObjectで 'つなげられるプロパティが書かれていないってのは問題があると思う。 'いくつかのサイトではAreasというプロパティがあると '述べていたのでそれを使って自力で実装した Option Explicit Sub hoge() Dim x As Collection Dim i As Range Dim j As Object 'Cell型がないようなので Dim k As Integer Dim flag As Boolean Set x = New Collection For Each i In Selection.Areas '1から始まるらしい For Each j In i.Cells If Not CollectionhasItem(x, j.Row) Then x.Add (j.Row) End If Next j Next If x.Count > 1 Then MsgBox ("You selected more than 2 rows") End If End Sub Function CollectionhasItem(ByRef c As Collection, ByVal v As Integer) Dim i As Integer 'For Each i In c ' For Each i in cってかけないらしい 'GenericsのあるVB.NETならともかく For i = 1 To c.Count If c(i) = v Then CollectionhasItem = True Exit Function End If Next CollectionhasItem = False End Function

その他の回答 (1)

  • kenpon24
  • ベストアンサー率64% (66/102)
回答No.2

こんなんでどうすか Sub test() Dim TempRG As Range Dim TempRow As Long TempRow = Selection.Row '選択しているセルのアドレスをRangeで包んでループ For Each TempRG In Range(Selection.Address) If TempRG.Row <> TempRow Then MsgBox "You are selecting two or more rows" Exit Sub End If Next End Sub

TYWalker
質問者

お礼

みなさん、回答ありがとうございます。 マッチポンプですみません、過去の質問の回答を眺めていたらこれでいしのげそうな気がします。 If Intersect(Selection.Cells.EntireRow, 1).Count <> 1 Then MsgBox "You are selecting two or more rows" Exit Sub End If みなさんのコードも研究します。 ありがとうございます!

関連するQ&A

  • エクセル VBA の行選択

    エクセルVBAで行を選択する場合 Rows(1,1).select Range(Cells(2,2),Cells(5, 5)).EntireRow.Select の方法があると知りました。 この数値の部分に変数を入れるとエラーがでてしまいました。 どうすれば変数で行を選択することができるのか教えてください。 2003を使用しております。

  • 複数行コピー、貼り付け実行時エラー1004

    ユーザー側が任意の場所を選択コピー し(2行毎) また 任意の位置に貼り付ける動作ですが 1回目のコピー、貼り付けは正常動作しますが 再度 コピー(任意の場所),貼り付け時に1004実行エラーが発生します。 下記はコードです。 どうかご教授お願いいたします。 Dim StartRow As Long, LastRow As Long, SRC As Long Sub コピー() If ActiveCell.Row < 76 Then Exit Sub StartRow = ActiveCell.Row: SRC = Selection.Rows.Count If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count - 1 Else LastRow = StartRow + Selection.Rows.Count End If Else StartRow = ActiveCell.Row - 1 If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count + 1 Else LastRow = StartRow + Selection.Rows.Count End If End If ActiveSheet.Range(ActiveSheet.Cells(StartRow, 1), ActiveSheet.Cells(LastRow, 19)).Copy End Sub Sub 貼付け() If ActiveCell.Row >= 76 Or Application.ClipboardFormats(1) <> -1 Then ActiveSheet.Unprotect If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row Else StartRow = ActiveCell.Row - 1 End If ActiveSheet.Paste Destination:=Cells(StartRow, 1): Application.CutCopyMode = False ActiveSheet.Protect End If End Sub

  • エクセル2010 VBA 行削除

    特定列が空白であれば行削除をしたいのですが、下記コードでうまく削除は出来るのですが、応答なしになったり、とても遅いのですが、もう少し早く処理出来る方法はありますか? E列が空白であれば行削除をしたいのですが・・ With Range("E13", Cells(Rows.Count, 5).End(xlUp)) .AutoFilter Field:=1, Criteria1:="" On Error Resume Next Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) If Err.Number = 0 Then rng.EntireRow.Delete On Error GoTo 0 .AutoFilter End With

  • マクロで複数の行をまとめて切り取りする方法

    Iの列のセルに「テスト」があったら、その行を切り取ってシート2に貼り付ける といった流れのコードが下記です。 Sub 切り取り() Dim i, LastRow As Long LastRow = Cells(Rows.Count, 9).End(xlUp).Row For i = 1 To LastRow If Cells(i, 9) = “テスト” Then Rows(i).Cut Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub ●Iの列のセルに「テスト」と「課題」があったら、その行を切り取ってシート2に貼り付ける といったものをしたいのです。 1. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト,課題” Then 結果エラー 2. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト&課題” Then 結果エラー 正常なコードを教えてくださいますか? 宜しくお願いします。

  • 条件に一致すれば行を削除するVBA

    こんにちは、以下のVBAについて質問をさせてください!m(_ _)m(タイプミスがあったらすみません、処理は成功しています。) Dim data As Integer For data = Cells(Rows,Count 1).End(xlUp).Row To 2 Step -1 If Cells(data,29) = "おやつ" Then Rows(data).EntireRow.Delete End If Next おやつ 上記だと29列目に「おやつ」という文字が入っている行は消えるのですが、For data~の部分を For data = 2 To Cells(Rows,Count 1).End(xlDown).Row に変えると何も起こらなくなります。 上の行から処理するか下の行から処理するかの違いで、やっていることは同じだと思うのですが、なぜ上の行から処理をしようとするとうまくいかないのでしょうか…?!Step -1のようにどこかに+1というのを入れないといけないのでしょうか…? どなたかご教示いただけると大変嬉しいです、よろしくお願いいたします<(_ _)>

  • ExcelのVBAでシート選択・最終行取得がうまくいかない。

    シートA・Bがあり、シートAの変数markが★だったら、シートBへいき、最終行を取得、ということをしたくて以下のようなコードをかきました。 Worksheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count Worksheets("B").Select Last1 = Cells(6).CurrentRegion.Rows.Count For w = 1 To Last1 Worksheets("B").Select Mark = Cells(w, 26) If Mark = "★" Then Sheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count MsgBox Last3 End If Next ですが、シートAの最終行が表示されます。 どこがちがうのでしょうか?

  • Excelセル範囲内の値のみ1行空欄にする

    下記コードでは1行づつ挿入により下段までずれてしまいます。 Excelセル範囲内の値のみ1行づつ開けるにはどのようにすれば良いでしょうか。 どなたか解る方よろしくお願いします。 Sub 空欄1行() Dim i As Long If TypeName(Selection) <> "Range" Then Exit Sub With Selection For i = .Rows.Count To 2 Step -1 Intersect(.Cells(i, 1).EntireRow, .Columns).Insert xlDown Next End With End Sub

  • エクセルWorksheet_SelectionChangeイベントでお訪ねします。

    1.シート全部のセルが選択されてしまった(Cells.Selectの状態)ことを判別する方法はどうすればいいでしょう? まさか、If Selection.Cells.Count = 256*65536 Then ではないでしょうねえ? 2.複数のセルが選択されたことの判別方法は、 If Selection.Cells.Count > 1 Then で正しいですか、または他にいい方法がありますか?

  • 選択したセルの、画面最上行から1つ下のセルを選択

    EXEL 2002 です。 任意に選択したセルの、画面最上行から1つ下(Rows.Count = 2)のセルを選択する場合のコードですが、 どうも解りません。 何卒、よろしくお願い致します。 ----------------------- Cells(2, Selection.Columns.Count).Select

  • エクセルのVBA

    AB列に複数行データがありB列の条件でその行のABのデータ を抽出し特定の場所に貼り付けたいのですが貼付け場所が 任意に選択できません。今はデータの無いA列から貼り付けていますが できればD列の1行目か2行目から貼り付ける方法を教えてください。 また今のコードでは貼付けたいデータの順番が下のデータからになってしまいます。 これも元のデータ順にしたいのでよろしくお願いします。 今使っているコードは下記の通りです。 For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1 If Cells(u, 2) < "96" And Cells(u, 2) <> "0" And Cells(u, 2) <> " " Then Range(Cells(u, 1), Cells(u, 2)).Select Selection.Copy Range("A1").End(xlDown).Offset(1, 0).Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Next

専門家に質問してみよう