- ベストアンサー
VBA チェックした項目以外を非表示
HohoPapaの回答
先ほどのコードでも大丈夫ですが より見やすいコードに手直ししてみました。 Option Explicit Private Sub CommandButton1_Click() Dim TgSheet As Worksheet '対象のワークシート Dim LastRow As Long '対象行末行番号 Dim i As Long 'チェックボックスカウンター Dim myMSG As String 'キャプション Dim HitFlg As Boolean Const CBoxCount = 3 'チェックボックスの数 本当は１４？ Application.ScreenUpdating = False '対象シートを設定 Set TgSheet = ThisWorkbook.Sheets(1) '対象シートを全行表示 TgSheet.Range(Rows(2), Rows(65536)).EntireRow.Hidden = False '対象行範囲末を取得 LastRow = TgSheet.Range("C65536").End(xlUp).Row '対象行範囲を全行非表示 TgSheet.Range(Rows(2), Rows(LastRow)).EntireRow.Hidden = True '対象行を表示 For i = 1 To CBoxCount If Me.Controls("CheckBox" & i).Value = True Then myMSG = Me.Controls("CheckBox" & i).Caption HitFlg = RowShow(TgSheet, myMSG, LastRow) If HitFlg = False Then MsgBox Me.ComboBox1.Text & "日に" & myMSG & "は使用していません。", vbInformation End If End If Next i Application.ScreenUpdating = True End Sub '//------------------------------------------- ' 指定列が指定文字列だったらその行を表示する関数 'TgSheet As Worksheet 対象シート 'ShowText As String 表示対象テキスト 'LastRow As Long チェックする行末の番号 '戻り値 該当行があったか '//------------------------------------------- Function RowShow(TgSheet As Worksheet, _ ShowText As String, LastRow As Long) As Boolean Const CheckCol = 3 'C列 Dim RC As Long '行カウンター Dim HitFlg As Boolean 'ヒットフラグ HitFlg = False For RC = 2 To LastRow '対象行末まで繰り返し If TgSheet.Cells(RC, CheckCol).Value = ShowText Then TgSheet.Range(Rows(RC), Rows(RC)).EntireRow.Hidden = False HitFlg = True End If Next RC RowShow = HitFlg End Function
関連するQ&A
- VBA 範囲選択時エラー
Private Sub Worksheet_SelectionChangeのVBAでA列B列C列でワンクリックで文字が入力できるように設定致しました。 その後、A列からC列を範囲選択してDeleteするとデバック 「実行時エラー 型が一致しません」と出てしまいます。業務上、そのセルのデータは一気に消したいので困っております。どなたか分かる方よろしくお願い致します。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range, rng_1 As Range, rng_2 As Range Application.EnableEvents = False Set rng_1 = Range("H17:H100") Set rng_2 = Range("I17:I100") Set rng_3 = Range("J17:J100") Set rng_4 = Range("K17:K100") Application.EnableEvents = True Set rng = Intersect(Target, rng_1) If Not rng Is Nothing Then Cancel = True If Target.Value = "" Then Target.Value = "(1)" Else Target.Value = "(1)" End If Else Set rng = Intersect(Target, rng_2) If Not rng Is Nothing Then Cancel = True If Target.Value = "(2)" Then Target.Value = Empty Else Target.Value = "(2)" End If Else Set rng = Intersect(Target, rng_3) If Not rng Is Nothing Then Cancel = True If Target.Value = "(3)" Then Target.Value = Empty Else Target.Value = "(3)" End If Else Set rng = Intersect(Target, rng_4) If Not rng Is Nothing Then Cancel = True If Target.Value = "(4)" Then Target.Value = Empty Else Target.Value = "(4)" End If End If End If End If End If End Sub
- 締切済み
- Visual Basic
- VBAの書き方を教えてください ２
以前にこちらで質問をさせて頂き、（http://okwave.jp/qa/q8451754.html）これに、VBAを追記していきたいのですが、移動したシートがアクティブする方法がわかりません。 移動したシートのA1000をアクティブにする場合、教えて頂いたVBAにどこに何を入れれば宜しいのでしょうか？ よろしくお願いします。 Private Sub CommandButton1_Click() Dim k As Long, myFlg As Boolean For k = 1 To Worksheets.Count If Worksheets(k).Name = Range("A1") Then myFlg = True Exit For End If Next k If myFlg = True Then Worksheets(k).Activate Else MsgBox "該当シートなし" End If End Sub
- ベストアンサー
- Excel（エクセル）
- VBAの書き方を教えてください 3
何度も申し訳ございません。 以前にもこちらで質問させて頂いている者です。 Sheet1のrange("A1")をVLOOKUPで検索後の文字を取得し、同じ名前のシートを検索し、さらにrange("A1000")をアクティブにしてここからコードをつなげて処理しています。 range("A1")の処理が終わったら、range("A2")の処理に入り、range("A3") range("A4")を続けて処理を行っているのですが、range("A4")でVLOOKUPの検索が空白の場合、On Error GoTo myErrorで次のrange("A5")の処理に入りますが、On Error Gotoは1回のみの処理しかできないみたいで、range("A５")が空白の場合、実行時エラー9が発生してしまいます。 教えて頂いたコードを解読し、On Error Resume Nextなどを使おうとしているのですが、上手くできません。 １から10まで質問しっぱなしなのですが、どなたかご協力を頂けないでしょうか。 とりあえず自分の必要なコードはある程度省いて、2つ分のみ記載します。 本来この後、10回同じ処理を行います。 よろしくお願い致します。 Private Sub 記帳_Click() On Error GoTo myError1 Dim i As Long Dim myFlg As Boolean For i = 1 To worksheets.Count If worksheets(i).Name = Range("A1").Value Then myFlg = True Exit For End If Next i If myFlg = True Then With worksheets(i) .Activate .Range("A1000").End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveCell = Range("J1") ActiveCell.Offset(0, 1).Select ActiveCell = Range("K1") End With Else MsgBox "該当シートなし" End If myError1: On Error GoTo myError2 For i = 1 To worksheets.Count If worksheets(i).Name = Range("A2").Value Then myFlg = True Exit For End If Next i If myFlg = True Then With worksheets(i) .Activate .Range("A1000").End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveCell = Range("J1") ActiveCell.Offset(0, 1).Select ActiveCell = Range("K1") End With Else MsgBox "該当シートなし" End If End sub
- ベストアンサー
- Excel（エクセル）
- エクセル VBA の質問です。
A2～A20までのセルに文字を入力した段階で、それぞれB2～B20に入力日時を入れるVBAを以下のように組んでいます。 しかし、同様の条件を同一シートのE2～E20・F2～F20にも入力・自動表示できるようにしなければならなくなり、困っています。 どのように記述を変えればよいのか、教えていただけたらと思います。 宜しく御願いいたします。 Sub Worksheet_change(ByVal Target As Range) Dim Rng As Range Dim c As Range Set Rng = Range("A2:A20") If Intersect(Target,Rng) Is Nothing Then Exit Sub For Each c In Intersect(Target,Rng) If Not IsEmpty(c) Then c.Offset(, 1).Value = Now Else c.Offset(, 1).ClearContents End If Next Rng.Offset(, 1).EntireColumn.AutoFit End Sub 申し訳ありませんが、何卒、宜しく御願いいたします。
- ベストアンサー
- オフィス系ソフト
- excel2000vba コントロールの値チェック
写真のように、ユーザーフォームの、各テキストボックスに数字を入れるようにしています。 そして、それぞれの、テキストボックスには、数字の下限値と上限値が設けられており、それに満たない数字が入力された場合、登録ボタンを押したときに、メッセージでそのテキストボックス名称を表示させるようにしようとしたいです。 また、値の下限値、コントロール名称、値の上限値は、workwheet1 のＡ列、Ｂ列、Ｃ列にそれぞれ入力されています。 下記プロシージャで異常な値のテキストボックスだけを、メッセージに表示させようと狙っていましたが、いつも、worksheet1の最下行のコントロールだけが、異常ですというメッセージが出てしまいます。 記述をどのように修正すれば、また、もっといい記述があれば、なども併せてアドバイスいただけないでしょうか。よろしくお願いします。 Private Sub CommandButton1_Click() Dim myctl As Object Dim endrow As Long Dim i As Long Dim myMSG As String endrow = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row For Each myctl In Controls For i = 2 To endrow If InStr(1, myctl.Name, Range("B" & i).Text) < Range("A" & i) Or InStr(1, myctl.Name, Range("B" & i).Text) > Range("C" & i) Then myMSG = Range("B" & i).Text & vbCrLf End If Next Next MsgBox myMSG & vbCrLf & "が異常です。" End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル VBA 表示範囲の簡素化
よろしくお願いします。 下記構文の簡素化ができないでしょうか。 CommandButtonが30個ほどあります。 ーーーーーーーーーー Private Sub CommandButton1_Click() Dim rng As Range Application.Goto Sheets("基本台紙").Range("A1") Set rng = Range("A1:D7") Rows.Hidden = True rng.EntireRow.Hidden = False Columns.Hidden = True rng.EntireColumn.Hidden = False rng(1).Select Unload Me UserForm1.Show vbModeless End Sub ーーーーーーーーーー Private Sub CommandButton2_Click() Dim rng As Range Application.Goto Sheets("基本台紙").Range("A1") Set rng = Range("A8:B21") Rows.Hidden = True rng.EntireRow.Hidden = False Columns.Hidden = True rng.EntireColumn.Hidden = False rng(1).Select Unload Me UserForm1.Show vbModeless End Sub ーーーーーーーーーー Private Sub CommandButton3_Click() Dim rng As Range Application.Goto Sheets("基本台紙").Range("A1") Set rng = Range("C8:D21") Rows.Hidden = True rng.EntireRow.Hidden = False Columns.Hidden = True rng.EntireColumn.Hidden = False rng(1).Select Unload Me UserForm1.Show vbModeless End Sub
- ベストアンサー
- Visual Basic
- VBAの記録を追加したい
エクセル2002使用です。 VBAで次のコードを使っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Target = Intersect(Range("C:C"), Target) If Target Is Nothing Then Exit Sub For Each Rng In Target If Rng.Value <> "" Then Rng.Offset(, -2).Value = Now Else ' (*) Rng.Offset(, -2).Value = "" ' (*) End If Next Rng End Sub （C列のセルに何か入力されると、A列の同じ行にその時刻が入る。） 同じシートで、F列に何か入力されるとE列の同じ行にその時刻が入るように書き直したいのですが、どうすればいいのでしょうか？ すいませんが、よろしくお願いします。
- ベストアンサー
- Visual Basic
- VBA? 色のついた文字のセルを数えたい
色のついた文字の記載があるセルをカウントしたく 色々調べました。結局VBAで設定する方法にしたのですが 設定しテストをするとどうしてもカウント数が合いません。 全くの初心者の為何が間違っているのか全く分かりません。 どなたか教えて下さい。 VBAも全く知らない者でしたので 調べて以下のものをそのまま貼り付けました。 Function CCount(Rng As Range, idx) Dim R As Range Dim Cnt As Long Application.Volatile For Each R In Rng If R.Font.ColorIndex = idx Then Cnt = Cnt + 1 Next R CCount = Cnt End Function Function GetIndx(Rng As Range) If Rng.Count > 1 Then GetIndx = vbNullString Exit Function End If GetIndx = Rng.Font.ColorIndex End Function 何が間違っているのでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセル VBA for文について
再び失礼します。 昨日VBAを始めた初心者です。 1、チェックボタン17個にそれぞれ変数を設定 2、２つだけチェックを入れると仮定して、実行ボタンを押したときに チェックが入っている2つの中で変数の大きいものをMax、小さいものをMinとしてシートに出力したいのですが、”ここ”と書いてあるところに Me("hensuu" & n). hensuu & n など入れてみたのですがエラーになります。 くだらないミスだと思いますがよくわかりません。 どなたかご教授お願いします。 Private Sub CommandButton2_Click() If Check1.Value = True Then hensuu1 = "9" End If If Check2.Value = True Then hensuu2 = "8" End If If Check3.Value = True Then hensuu3 = "7" End If If Check4.Value = True Then hensuu4 = "6" End If If Check5.Value = True Then hensuu5 = "5" End If If Check6.Value = True Then hensuu6 = "4" End If If Check7.Value = True Then hensuu7 = "3" End If If Check8.Value = True Then hensuu8 = "2" End If If Check9.Value = True Then hensuu9 = "1" End If If Check11.Value = True Then hensuu10 = "1/2" End If If Check11.Value = True Then hensuu11 = "1/3" End If If Check12.Value = True Then hensuu12 = "1/4" End If If Check13.Value = True Then hensuu13 = "1/5" End If If Check14.Value = True Then hensuu14 = "1/6" End If If Check15.Value = True Then hensuu15 = "1/7" End If If Check16.Value = True Then hensuu16 = "1/8" End If If Check14.Value = True Then hensuu17 = "1/9" End If Dim n As Long Dim Max As Long Dim Min As Long For n = 1 To 17 If Me("Check" & n).Value = True Then Max = ”ここ” If Me("Check" & n).Value = True Then Exit For Next n For n = Max To 17 If Me("Check" & n).Value = True Then Min = ”ここ” If Me("Check" & n).Value = True Then Exit For Next n Worksheets("Sheet1").Range("A1") = Min Worksheets("Sheet1").Range("B1") = Max MsgBox hensuu End Sub
- 締切済み
- オフィス系ソフト
- エクセルVBAにてプログラムされているシートに別のシートからマクロのモジュールにて貼り付けるとエラーになります。
エクセルVBAにてプログラムされているシートに別のシートからマクロのモジュールにて普通のデータを貼り付けるとエラーになります。 何卒エラーの解除方法を教えて下さい。 また、合わせて下記プログラムは四角形等のオートシェイプの書式に対応していますが、 同じシート上に写真等の図の書式があるとエラーになります。 お手数ですが、解決方法を教えて下さい。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim C As Variant Dim i As Integer Dim Rng As Range For Each Rng In Target If Not Intersect(Range("e36:i40"), Rng) Is Nothing Then Select Case Rng.Row Case 36 C = Split("3 0 0 0 0") Case 37 C = Split("0 3 0 0 0") Case 38 C = Split("0 0 3 0 0") Case 39 C = Split("0 0 0 3 0") Case 40 C = Split("0 0 0 0 3") End Select Else C = Split("0 0 0 0 0") End If For i = 0 To 4 ActiveSheet.Shapes(i + 1).Select Selection.Font.ColorIndex = C(i) Next i Next Rng Target.Select End Sub
- 締切済み
- その他(業務ソフトウェア)
お礼
お礼が遅くなってしまい申し訳ございません。 いただいたコードで行いたいことの確認ができました。 本当にありがとうございました。