• ベストアンサー

エクセルVBA オートフィルタの選択を元に戻す

エクセルのVBAで、次のことはできるでしょうか。 ブックの中の3つのシートはオートフィルタが設定してあり、任意で操作し、検索に使っています。(オートフィルタを設定しないしーとが2つあります) ・別のシートにチェンジしたら、チェンジ前のシートがオートフィルタで特定の行だけを表示していたら、オートフィルタを <すべて> に戻して、消えていた行を全て表示させたいのです。(オートフィルタは次回にまた使うので、データ-フィルタ-オートフィルタでオートフィルタ自体を解除してしまうような状態にはしたくありません) ・同じく、上記のことをブックを閉じるときにも実行したいのです。 ちなみに、オートフィルタをかけてあるシートには、以下のコードがあります。 よろしくお願いします。 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) With Sheets("印刷") .Range("E15:E17").Value = _ Application.Transpose(Cells(Target.Row, 7).Resize(, 3).Value) .Range("AA16").Value = _ Cells(Target.Row, 10).Value .Range("AQ16").Value = _ Cells(Target.Row, 11).Value .Range("AX16").Value = _ Cells(Target.Row, 12).Value End With With Sheets("施設") .Range("C2").Value = _ Cells(Target.Row, 10).Value End With Cancel = True Sheets("施設").Select End Sub

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

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.4

こんにちは。#3のWendy02です。 何度も見直しましたが、今のコードにどこと言って問題があるようには思えないのですが。 変数は、Sub の行の下に置く、というぐらいですが、これは見かけのためだけで、それでトラブルはありません。 オートフィルタを、データ-フィルタ-オートフィルタで、一回、解除して、もう一度、オートフィルタを設置してみたらいかがですか?もしかしたら、かなり大きなファイルではありませんか?もし、そうだとするなら、メモリ上の問題になります。 後は、ステップモードで動作試験をしてもらう、という方法ぐらいか見当たりません。 F8 を一回押すごとに、進んでいきますから、それで、どう変化するか、ということです。 Private Sub test() 'ブックを閉じるとき  Dim Wsh As Worksheet  For Each Wsh In Worksheets(Array("名簿", "施設"))   With Wsh    If .AutoFilterMode Then     If .FilterMode Then      .ShowAllData     End If         End If   End With  Next  'ThisWorkbook.Save End Sub それとも、#1さんのコードに、AutoFilterMode の判定のオプションをつけてみるか、どうかですね。

saitama090
質問者

お礼

すみませんでした。私が、データは5行目以降に入れていて、その一つ上の「4行目」はわざと空白セルにしていました。(これは、転記先を簡単に空欄にするためだったのです)しかし、それによりオートフィルターが4行目で止まってしまったようです。 4行目は、全くの空白ではなく、一文字分スペースを入れました。 すると、すべてうまく作動しました。 本当に、私が至らないせいで、余計な確認をさせてしまいました。 お詫びいたします。 また、ありがとうございました。

その他の回答 (3)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

#2 の訂正です。 閉じるときに、一旦、保存しないとだめでした。 開いた時に選択されたフィルタモードに戻っています。 Private Sub Workbook_BeforeClose(Cancel As Boolean) '略  Next 'ここに↓を入れてください。  ThisWorkbook.Save End Sub

saitama090
質問者

補足

ありがとうございました。 ThisWorkbook に設定したのですが、オートフィルタがうまく動かなくなってしまいました。 オートフィルタの三角印をクリックしても、その列に記録しているテキストデータがプルダウンされずに、(すべて)(トップテン)(オプション)(空白のセル)(空白以外のセル)だけが表示されるようになってしまいました。 私の方法の何が悪かったのでしょうか。よろしくご指導ください。 ThisWorkbook には、別のコードもあったので、少しいじりました。それが悪かったのでしょうか。 ThisWorkbook の Workbook に、下記のコードを記載してあります。 '開いたときに、最初に会員名簿から画面が始まるようにする。 Private Sub Workbook_Open() Sheets("名簿").Activate End Sub '保存するときに Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 'クリア、印刷画面から入力情報を消す(間違って印刷する事故防止のため) ThisWorkbook.Sheets("印刷").Range("AX16,AQ16,AA16,E15:E17").ClearContents ThisWorkbook.Sheets("施設").Range("C2").ClearContents 'コピー ThisWorkbook.Sheets("施設").Range("C3").Value = ThisWorkbook.Sheets("施設").Range("G6").Value End Sub '終了するときに Private Sub Workbook_BeforeClose(Cancel As Boolean) 'クリア 印刷画面から入力情報を消す(間違って印刷する事故防止のため) ThisWorkbook.Sheets("印刷").Range("AX16,AQ16,AA16,E15:E17").ClearContents ThisWorkbook.Sheets("施設").Range("C2").ClearContents 'コピー ThisWorkbook.Sheets("施設").Range("C3").Value = ThisWorkbook.Sheets("施設").Range("G6").Value 'ブックを閉じるとき Dim Wsh As Worksheet For Each Wsh In Worksheets(Array("名簿", "施設")) With Wsh If .AutoFilterMode Then If .FilterMode Then .ShowAllData End If Else '本来は、ここに、.Range("A1").AutoFilter を加える End If End With Next ThisWorkbook.Save End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) 'シートを換えるとき Select Case Sh.Name Case "名簿", "施設" With Sh If .AutoFilterMode Then If .FilterMode Then .ShowAllData End If Else '本来は、ここに、.Range("A1").AutoFilter を加える End If End With End Select End Sub

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

こんばんは。 こんな感じでしょうか? オートフィルタの場所が書かれていないので、オートフィルタがない場合については、省略されています。 コードの意味は、オートフィルタがあるかどうかを調べ、次にフィルターモードになっているかを調べ、フィルターモードなら、全部の項目を出せ、という命令になっています。 以下は、ThisWorkbook に設定してください。 'ThisWorkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) 'ブックを閉じるとき  Dim Wsh As Worksheet  For Each Wsh In Worksheets(Array("印刷", "施設"))   With Wsh    If .AutoFilterMode Then     If .FilterMode Then      .ShowAllData     End If    Else      '本来は、ここに、.Range("A1").AutoFilter を加える    End If   End With  Next End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) 'シートを換えるとき  Select Case Sh.Name   Case "印刷", "施設"    With Sh     If .AutoFilterMode Then      If .FilterMode Then       .ShowAllData      End If     Else        '本来は、ここに、.Range("A1").AutoFilter を加える     End If    End With    End Select End Sub

saitama090
質問者

お礼

ThisWorkbook に設定する方法を教えていただき、ありがとうございました。 勉強させていただきます。

回答No.1

オートフィルタが設定してある3つのシートに以下のソースを貼り付けて下さい。 Private Sub Worksheet_Activate()  Range("A1").Select  Selection.AutoFilter  Selection.AutoFilter End Sub これは、一旦オートフィルタを解除して、再度オートフィルタをかけています。 > 同じく、上記のことをブックを閉じるときにも実行したいのです。 これは、行なう必要がなくなります。 フィルターが掛かった状態で閉じても、ブックを開いてそのシートを表示させると、全件表示されます。 外していたらゴメンです。 ではでは。

saitama090
質問者

お礼

できました。なるほど、一旦オートフィルタを解除して、再度オートフィルタをかけるという考え方をするのですね。 勉強になりました。 ありがとうございました。

関連するQ&A

  • excel VBA 2つのプロシージャを1つに

    いつもお世話になっております。 初心者ですが、苦しみながらもexcelでデータベースを作成しております。 さて Worksheet_Change のイベントが2つあり、これを一つにまとめようとしているのですが、がんばっているんですが、自分ではどうしてもうまくいかない為、投稿させていただきました。 コードは下記2つです。 また、どういったものを作ろうとしているのか説明不足でご指摘を頂戴することもありますので、試作段階のファイルですが、アップローダーにあげさせていただきました。確認頂ければ幸いです。 ■アプロダ 投稿No 4514 http://www.kent-web.com/pubc/book/test/uploader/uploader.cgi ■作ろうとしているデータベースの概要 inputシート・・・データを直接入力して、また、データや写真を閲覧をするシート dataシート・・・データを格納するシート、オートフィルタを使って、曖昧検索フィルタもここでかけたりします。 どうか良いお知恵を拝借させていただきたくよろしくお願いします。 '一つ目のプロシージャ(Noセルに数字が入ると、そのNoのデータを自動的にdataシートまで読みにいって表示させます) Private Sub WorkSheet_Change(ByVal Target As Range) 'No入力してデータ反映 Dim fRange As Range Dim fRow As Long If Target.row <> 4 Then Exit Sub If Target.Column <> 3 Then Exit Sub Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then '見つからなかった? MsgBox "入力された顧客コードが存在しません。", vbExclamation Exit Sub End If fRow = fRange.row '検索された顧客DCの行位置を求める Range("F4").Value = Sheets("data").Cells(fRow, 2).Value Range("C5").Value = Sheets("data").Cells(fRow, 3).Value Range("C6").Value = Sheets("data").Cells(fRow, 4).Value Range("C7").Value = Sheets("data").Cells(fRow, 5).Value Range("F5").Value = Sheets("data").Cells(fRow, 6).Value End Sub '二つ目のプロシージャ(写真を表示させるためのコードです) Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target.Address Case "$k$4" myLoadPicture "board_Image", Target.Text, Range("I5") Case "$K$17" myLoadPicture "map_Image", Target.Text, Range("I18") Case Else Exit Sub End Select End Sub

  • エクセル VBA シートの選択 

    windows XP でエクセル2000を使っています。 Sub aaa() Sheets("Sheet1").Select Dim a As String a = Cells(2, 4) Sheets(a).Select Range("A1").Select End Sub というマクロだと セルに入っている値のシート名を探してくれます。 ですが Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Intersect(Target, Range("B11:b683")) Is Nothing Then Exit Sub Worksheets("Sheet1").Range("C2").Value = Target.Value Dim b As String b = Range("C2).value (←ここをcellsにしてもダメ) Sheets(b).Select Range("A1").Select End Sub これだとsheets(b)を選びません。Sheets(b).Selectのところが黄色くなります。 何処が間違えているのでしょうか。 全くの素人ですが、仕事で必要に迫られています。 わかりやすく回答・解説くれると助かります。

  • エクセルのオートフィルターがかかっていたら消すVBA

    いつもお世話になっております。 作業が終了して全てのシートを初期化する場合に、オートフィルターで抽出した状態でデータを消すと、隠れていた部分が残ってしまいます。 もし、そのシートのA1~D1までにフィルターがかかっていたら、フィルターを消す、かかっていなければ、そのままシート全体のデータを消すというマクロはどう書けばよろしいのでしょうか? -例- Sheets("ABC").Select If Range(Cells(1,1),Cells(1,4))にフィルターがかかっていたらThen  フィルターを消す  Cells.ClearContents Else Cells.ClearContents End If こんなことをしたいのですが、伝わりましたでしょうか? よろしくご指南くださいませ。

  • エクセルVBAについて

    こんにちわ! 今、エクセルでAシートの入力した項目をBのシートへデーターが入力できるようなシステムを以下のようにくみました。 そこでBシートにデーターが入力されるのですが20行まで入力すると入力できないようにしたいのですが、なかなか上手くいきません。 A1からF20まで書式のロックを外しそれ以外のセルは保護をかけたのですがその状態でVBAを使って20行以上入力できませんという感じのエラー表示をしたいのですが、どうすればいいでしょうか? VBAは初心者ですが宜しくお願いします。 Private Sub CommandButton1_Click() Dim row As Integer row = WorksheetFunction.CountA(Sheets("date").Columns(1)) + 1 Sheets("date").Cells(row, 1).Value = Range("B2").Value row = WorksheetFunction.CountA(Sheets("date").Columns(2)) + 1 Sheets("date").Cells(row, 2).Value = Range("B3").Value row = WorksheetFunction.CountA(Sheets("date").Columns(3)) + 1 Sheets("date").Cells(row, 3).Value = Range("B4").Value row = WorksheetFunction.CountA(Sheets("date").Columns(4)) + 1 Sheets("date").Cells(row, 4).Value = Range("B5").Value row = WorksheetFunction.CountA(Sheets("date").Columns(5)) + 1 Sheets("date").Cells(row, 5).Value = Range("B6").Value row = WorksheetFunction.CountA(Sheets("date").Columns(6)) + 1 Sheets("date").Cells(row, 6).Value = Range("B7").Value Sheets("統制入力").Select Range("B17").Select ActiveWindow.SmallScroll Down:=-9 Range("B3:B7").Select Selection.ClearContents Range("B1").Select End Sub

  • エクセルVBAで最小値を求めたいのですが

    下記はある表の最大値を求めるものですが 同様の条件で最小値を求めようと思い 「MAX」の箇所を「MIN」差し替えてできると思っていたのですが 最小値がのかわりに「0」が表示されてしまいます。 そのように修正すればよいでしょうか? private sub worksheet_change(byval Target as excel.range)  if target.cells(1) = "" then exit sub  if target.address = "$A$1" then   Range("C10:C65536").ClearContents   With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C"))    .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)"    .Value = .Value   End With  elseif target.address = "$E$1" then   Range("G10:G65536").ClearContents   With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G"))    .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)"    .Value = .Value   End With  end if end sub

  • エクセルVBAについて

    http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを E列に日付 F列に売上 G列に結果 でやりたいのですが この時A列~C列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか?

  • VBAについて教えて下さい

    EXCEL2010を使用中。 独学で、Web上で色々検索したものをパクリながら VBAを組んでるようなレベルです。 今回教えて頂きたい内容ですが、 カード型の入力シート「Sheet名:入力」を作成して、 登録ボタンでデータベースシート「Sheet名:スケジュール」に 書き足していくような業務スケジュール表を作成中です。 わざわざそんな手のこんだものを 作らなくてもと思われるかもしれませんが 諸事情があっての事なので 登録ボタンのVBAは Private Sub 登録_Click() Dim row As Integer row = WorksheetFunction.CountA(Sheets("スケジュール").Columns(1)) + 1 Sheets("スケジュール").Cells(row, 1).Value = Range("Q2").Value Sheets("スケジュール").Cells(row, 2).Value = Range("G6:G7").Value Sheets("スケジュール").Cells(row, 3).Value = Range("G8:G9").Value Sheets("スケジュール").Cells(row, 4).Value = Range("G10:G11").Value Sheets("スケジュール").Cells(row, 5).Value = Range("G12:G13").Value Sheets("スケジュール").Cells(row, 6).Value = Range("G14:G15").Value Sheets("スケジュール").Cells(row, 7).Value = Range("G16:G17").Value Sheets("スケジュール").Cells(row, 8).Value = Range("G18:G19").Value Sheets("スケジュール").Cells(row, 9).Value = Range("G20:G21").Value Sheets("スケジュール").Cells(row, 10).Value = Range("G22:G23").Value Sheets("スケジュール").Cells(row, 11).Value = Range("G24:G25").Value Sheets("スケジュール").Cells(row, 12).Value = Range("M6:M7").Value Sheets("スケジュール").Cells(row, 13).Value = Range("M8:M9").Value Sheets("スケジュール").Cells(row, 14).Value = Range("M10:M11").Value Sheets("スケジュール").Cells(row, 15).Value = Range("M12:M13").Value Sheets("スケジュール").Cells(row, 16).Value = Range("M14:M15").Value Sheets("スケジュール").Cells(row, 17).Value = Range("M16:M17").Value Sheets("スケジュール").Cells(row, 18).Value = Range("M18:M19").Value Sheets("スケジュール").Cells(row, 19).Value = Range("M20:M21").Value Sheets("スケジュール").Cells(row, 20).Value = Range("M22:M23").Value Sheets("スケジュール").Cells(row, 21).Value = Range("M24:M25").Value Sheets("スケジュール").Cells(row, 22).Value = Range("S6:S7").Value Sheets("スケジュール").Cells(row, 23).Value = Range("S8:S9").Value Sheets("スケジュール").Cells(row, 24).Value = Range("S10:S11").Value Sheets("スケジュール").Cells(row, 25).Value = Range("S12:S13").Value Sheets("スケジュール").Cells(row, 26).Value = Range("S14:S15").Value Sheets("スケジュール").Cells(row, 27).Value = Range("S16:S17").Value Sheets("スケジュール").Cells(row, 28).Value = Range("S18:S19").Value Sheets("スケジュール").Cells(row, 29).Value = Range("S20:S21").Value Sheets("スケジュール").Cells(row, 30).Value = Range("S22:S23").Value Sheets("スケジュール").Cells(row, 31).Value = Range("S24:S25").Value Sheets("スケジュール").Cells(row, 32).Value = Range("S26:S27").Value Range("Q1").Select End Sub としています。 この時、移行するセル内の文字数が指定文字数を超えると、 移行した先のセルの書式設定を「折り返して全体を表示する」に 設定変更をしたいですのですが、その方法について ご教授いただけないでしょうか? 因みに現在の設定は、「縮小して全体を表示する」としています。

  • VBA 重複する番号があるときは値を貼り付けない

    すみません。 理解しているのが少しなので、ちょっとシンプルなVBAを書いています。 1つのブックに 登録シート =Sheets("登録")           顧客情報シート=Sheets("顧客情報")          販売情報シート=Sheets("販売情報")          売り上げシート=Sheets("売り上げ") 登録シートのボタンを押すと、登録シートに入力した情報が、 各シートに分かれて値が入るようにしています。 下記がコードです。 Private Sub CommandButton1_Click() Dim row As Integer ★★★ row = WorksheetFunction.CountA(Sheets("顧客情報").Columns(2)) + 1 Sheets("顧客情報").Cells(row, 2).Value = Range("A2").Value Sheets("顧客情報").Cells(row, 3).Value = Range("A5").Value Sheets("顧客情報").Cells(row, 4).Value = Range("B8").Value ★★★ row = WorksheetFunction.CountA(Sheets("販売情報").Columns(2)) + 1 Sheets("販売情報").Cells(row, 2).Value = Range("C26").Value Sheets("販売情報").Cells(row, 3).Value = Range("J1").Value row = WorksheetFunction.CountA(Sheets("売り上げ").Columns(2)) + 1 Sheets("売り上げ").Cells(row, 2).Value = Range("H1").Value Sheets("売り上げ").Cells(row, 3).Value = Range("K6").Value End Sub もっと簡単な書き方あるよ。。。と言われるでしょうが、 私が理解して修正等ができるのが、上記でした。。 やりたいことは、2点です。 (1)重複は貼り付けをしない。  登録シートのセル A2に入った数字が、顧客情報シートのB列のどこかに、  既に入力がされていた場合は、★★★で囲まれた部分の値を貼り付けず、  その先の販売情報のシートに貼り付ける作業へと進めたい。  IF などを使えばできますでしょうか?   (2)各シートに入力したものを貼り付けた際、A2より下から順番に各シートのCells(row, 1)の位置に、連番をつけたい。 何卒宜しくお願い申し上げます。

  • EXCEL VBA オートフィルタの値コピー

    ほぼ初心者ですのでよろしくお願いします。 Sheet2にデータがありそのデータをオートフィルタで日付から抽出してSheet3にコピーして、その後Sheet1の表に該当項目をコピーする際についてですが、オートフィルタ後、1日当たり行は10~15行あります、そのうちG列にはデータが通常2つのセルに値があるだけでほかの行は空欄です。(日によってどの行になるかはわかりません)この2つのセルの値をそれぞれSheet1のM10とM11コピーしたいのです、 ちなみにセル番地は下記の方法で取得できましたが、値の取得ができません。 Range("D1").Value = Worksheets("sheet1").Range("A1").End(xlDown).Row Range("D2").Value = Worksheets("sheet1").Range("A65536").End(xlUp).Row Sub データコピー() Range("AB17") = Format(Sheet3.Range("A3").Value, "yy") Range("AE17") = Format(Sheet3.Range("A3").Value, "mm") Range("AH17") = Format(Sheet3.Range("A3").Value, "dd") Range("AK17") = Format(Sheet3.Range("A3").Value, "aaa") Range("D22") = Sheet4.Range("D3").Value Range("D25") = Sheet4.Range("E3").Value Range("H22") = Sheet4.Range("F3").Value Range("D22") = Sheet4.Range("G3").Value Range("L22") = Sheet4.Range("K3").Value Range("Q22") = Sheet4.Range("L3").Value Range("U22") = Sheet4.Range("M3").Value .   .   . End Sub

  • エクセルVBAとmsg関数

    こんばんは。 エクセルVAB初心者です。 現在、エクセル2003で以下の画像のような 表を作成しました。 上段が請求書データ(シート1)で、 下段が請求書の印刷フォーム(シート2)です。 VBAで実行する処理は、請求書データNOをそれぞれ 任意でクリックし、選択しているNOの行データをシート2にそれぞれ 転記していき、一括で印刷するものです。 以下のように、コードを作りました。 Sub 発行() Dim i As Range Dim m As Integer Dim W1 As String With Selection W1 = Cells(.Row, 1).Value & " ~ " & _ Cells(.Rows.Count + .Cells(1, 1).Row - 1, 1).Value & vbCrLf & _ " の請求書を発行しますか?" m = MsgBox(W1, vbYesNoCancel) If m <> vbYes Then Exit Sub For Each i In .Resize(, 1) With Sheets("Sheet2") .Range("b1").Value = Cells(i.Row, 1).Value .Range("e1").Value = Cells(i.Row, 2).Value .Range("c5").Value = Cells(i.Row, 3).Value .Range("b3").Value = Cells(i.Row, 4).Value .Range("c6").Value = Cells(i.Row, 5).Value .PrintOut End With Next End With End Sub ここで質問なのですが、"の請求書を発行しますか?" の後に、選択している行の数を(合計O枚)のように 表示したいのですが、どのようなコードを入れればいいのでしょうか。 また、メッセージボックスのウインドウの中の文字が 小さいので、もう少し大きくしたいのです。 以上の2点ですが、お願いします。

専門家に質問してみよう