• ベストアンサー

エクセル VBA 検索 スクロール

お世話になります。 A列に製品名、B列に場所と詳細を表した表です。 E1に製品名を入れて検索ボタンを押すと右隣のセルの値がE1に表示され検索件数がMsgBoxに表示されるものをこのページで聞いたりしながら作りました。 'Dim 対象セル As Range 'Dim 最初のセル番地 As String 'Dim 検索件数 As Long Cells.Interior.ColorIndex = xlNone If Range("E1").Value = "" Then Exit Sub Set 対象セル = Range("A2:A1287").Find(What:=Range("E1").Value, After:=Range("A1287"), lookAt:=xlWhole) If 対象セル Is Nothing Then Exit Sub 最初のセル番地 = 対象セル.Address Do 対象セル.Interior.ColorIndex = 37 検索件数 = 検索件数 + 1 Set 対象セル = Range("A2:A1287").FindNext(対象セル) Loop While 対象セル.Address <> 最初のセル番地 Range("E3").Value = 対象セル.Offset(, 1).Value MsgBox "検索件数は" & 検索件数 & " 件です" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) End Sub 今回質問したいのは検索したセルを含む行(製品名によって複数あります)を自動で一番上、A5でウィンドウの固定をしてあるのでA6からの表示になるようにスクロールするにはどのようにしたらいいでしょうか?よろしくお願いします。

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

  • ベストアンサー
  • xls88
  • ベストアンサー率56% (669/1189)
回答No.1

「ウィンドウの固定」を心配しなくても大丈夫です。 Application.Goto Reference:=対象セル, Scroll:=True

miyabi7
質問者

お礼

出来ました、回答ありがとうございます。 右隣のセルの値がE1に表示され・・E1ではなくてE3でした ありがとうございました。

その他の回答 (1)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

自分のコードばかり書かないで、実例を挙げて、聞きたいことを明確に説明すること。特に完成形はどのようなものか。 例 A10以下(A1287なんて回答者にはテストがやりにくい。A1の近くの行で実例を作るのが親切) a s d f g a d f a f a s f ーーー E1にaなど条件値を入力。 その近くにコマンドボタンを1つ貼り付け。 ーー Private Sub CommandButton1_Click() a = Cells(1, "F") Range("A9:A100").Find(what:=a).Select f = Selection.Row MsgBox f k = 1 Do Range("A9:A100").FindNext(after:=Selection).Select 'MsgBox Selection.Row k = k + 1 Loop While Selection.Row <> f MsgBox "件数=" & k - 1 ActiveWindow.ScrollRow = f End Sub 上記だと、aが最初に見つかる、元の10行目が一番上(固定行の次行)に来る。 入力条件やコマンドボタンが見えなくなるので第2行目でウインドウ枠の固定をしておく。最初行だけ一番上に表示すればよいのか? これでよいのか? ーー または aのある10,15、18,20行が残り、他が折りたたまれて 10 a 15 a 18 a 20 a のように表示したいのか(良くわからない)? それならフィルタの方が相応しいのでは。 ーーー 上記で質問者の意図と違う点を補足のこと。

miyabi7
質問者

お礼

説明足らずでした、A列は名前順で並んでいます。 Application.Goto Reference:=対象セル, Scroll:=True 今回求めたい事はこの方法でできました。 ありがとうございました。

関連するQ&A

  • エクセル マクロ 検索

    お世話になります。 範囲がA2からK221までの表があります。 検索して検索されたセルの左のセルを表示するマクロを組みたいのですが、検索する文字(数値)はE1に、検索結果はK1に表示するようにするにはどのようにしたらいいでしょうか? Sub FIND_DATA1() ' FIND_DATA1 Macro ' マクロ記録日 : 2006/9/1 ユーザー名 : ' Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole).Activate End Sub Sub Data_Find3() Dim 対象セル As Range Dim 最初のセル番地 As String Dim 検索件数 As Long Cells.Interior.ColorIndex = xlNone If Range("E1").Value = "" Then Exit Sub End If Set 対象セル = Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole) 最初のセル番地 = 対象セル.Address Do 対象セル.Interior.ColorIndex = 37 検索件数 = 検索件数 + 1 Set 対象セル = Cells.FindNext(対象セル) Loop While 対象セル.Address <> 最初のセル番地 MsgBox "検索件数は" & 検索件数 - 1 & " 件です" End Sub 本を見たり調べたりでここまでできたんですがこれだと検索件数、検索結果が色付きになるだけで使い勝手がいまいちです。 よろしくお願いします。

  • excel vbaについてです

    VBA初心者で、暇な時にいろいろためしています。 以下のマクロを組んだのですが、エラーがでてうまくいきません。 どこがいけないのかご指摘願います。 Sub ather() Dim A As Range Dim B As Range Dim i As Integer With ThisWorkbook.Worksheets("Sheet1") For i = 1 To 30 Set A = Cells(i, 1) Set B = Cells(1, i) If Not .Range(A).Interior.ColorIndex = vbYellow Then GoTo port10 If Not .Range(B).Interior.ColorIndex = vbRed Then GoTo port10 .Range(B).Offset(, 1).Value = "○" port10: Next i End With End Sub イメージとしてはセルの塗りつぶしが黄色で、かつ右隣のセルの塗りつぶしが赤の時に、 赤色セルの右隣のセルに○を表示させようとしているのですが。。。 こうしたらいいんじゃない?といったアドバイスもお願いします(-人-)

  • エクセル 2010 マクロ 検索

    http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索()  Dim Ws1 As Worksheet, Ws2 As Worksheet  Dim strKey As Variant  Dim s As String  Dim c As Range, bln As Boolean  Dim rng1 As Range  Dim cnt As Long    Set Ws1 = Sheet1  Set Ws2 = Sheet2    Ws1.Select    With Ws2   strKey = Application.Transpose(.Range("A1").Resize(2).Value)   strKey = Join(strKey, "")  End With    If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub      With Ws1   Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp))   For Each c In rng1.Offset(, -10)     'D,E,F,G,H,I,Kを検索    s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value &        If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then     c.End(xlToRight).Activate c.Offset(0, 2).Value = Date          c.Resize(1, 14).Interior.ColorIndex = 6     bln = True     Exit For    End If   Next c      If Not bln Then    Ws2.Select    MsgBox "リストに存在しません", vbExclamation, "NotFound"   Else '加える    Call ReSearch(Ws1.Range("M2"), c.Row)    '再設定    Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))    MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation   End If  End With  Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2)  Dim i As Long  Dim cnt As Long  For i = 1 To rng1.Rows.Count   If VarType(rng2.Cells(i, 1)) = vbDouble Then    If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then     cnt = cnt + 1    End If   End If  Next i  DoubleCountBlank = cnt End Function 宜しくお願い致します。

  • エクセルVBAを教えて下さい

    エクセルの表で -AB C D E F 1年月--1801 2------ 3------ 4------ (-)は空欄でセルE1=18、F1=1とします。 コントロールボックスをつかって Private Sub Command登録_Click() Dim d1 As Long Dim d2 As Long Dim ret As Variant Dim FindValue As String Dim TotalAddress As String If Range("E1").Value = "" Or Range("F1").Value = "" Then MsgBox "該当する場所にデータが入っていません。", vbCritical Exit Sub End If d1 = Range("A65536").End(xlUp).Offset(1).Row d2 = Range("B65536").End(xlUp).Offset(1).Row FindValue = """" & Range("E1").Value & Range("F1").Value & """" TotalAddress = Range("A1").Resize(d1).Address & "&" & Range("B1").Resize(d1).Address ret = Evaluate("MATCH(" & FindValue & "," & TotalAddress & ",0)") If IsError(ret) Then Cells(d1, 1) = Range("E1").Value Cells(d2, 2) = Range("F1").Value Else MsgBox "既に同じ組み合せがあります。", vbInformation End If End Sub というものを作ったのですが、E1=18、F1=1及びコマンドボタンを別シートに作成し、上記の表への登録をできるようにしたいのですが、なにかいい方法はありませんか?

  • エクセルVBAで指定したセルへジャンプするコード(追加の追加質問です)

    http://oshiete1.goo.ne.jp/qa2903797.html たびたびすみません。最後にひとつだけお願いします。 お教えいただいた下のコードは順調に動作するのですが、 対象セルが結合セルの場合、エラーが出てしまいます。 とまってしまうコードの部分は With Selection.AddComment です。 エラーメッセージにはプロシージャの呼び出し、 または引数が不正です。(Error 5)と書いてあります。 結合セルは動作しないものでしょうか? Sub test01() Dim x As String Dim ThisSheet_Name As String Dim Sheet_Name As String Dim Range_Name As String Dim I As Integer, n As Integer Dim Ans As Integer Dim myComment As String '新規追加 Dim Colors As Integer '新規追加 ThisSheet_Name = ActiveSheet.Name '設定シート Select Case Workbooks.Count Case 1 MsgBox "チェックするファイルがありません。" Exit Sub Case 2 For n = 1 To 2 If Workbooks(n).Name <> ThisWorkbook.Name Then x = Workbooks(n).Name '開いている“もうひとつのブック”の名前 End If Next Case Else MsgBox "他に開いているファイルが複数のため対象を特定できません。" Exit Sub End Select I = 0 Do While (1) With ThisWorkbook.Sheets(ThisSheet_Name) If .Range("A3").Offset(I, 0).Value = "" Then MsgBox "検査項目は以上です。" ThisWorkbook.Activate Exit Do 'A列の3行目以下が、空白なら終わる End If Sheet_Name = .Range("A3").Offset(I, 0).Value Range_Name = .Range("B3").Offset(I, 0).Value myComment = .Range("C3").Offset(I, 0).Value End With Windows(x).Activate Sheets(Sheet_Name).Select Range(Range_Name).Select Colors = Selection.Interior.ColorIndex '新規追加 Selection.Interior.ColorIndex = 6 With Selection.AddComment .Visible = True .Text myComment End With Range(Range_Name).Select Ans = MsgBox("「次をチェックしますか?」", vbYesNo) Selection.Interior.ColorIndex = Colors '修正 Selection.ClearComments '新規追加 If Ans = vbYes Then I = I + 1 Else Exit Do End If Loop End Sub

  • エクセルVBAについて

    VBAを勉強しているものです。 添付資料のようなグラフを作っております。 ############################################################### Sub 時間グラフ作成() Dim 開始 As Date Dim 終了 As Date Dim 開始経過時間 As Long, 終了経過時間 As Long Dim 開始目盛 As Long, 終了目盛 As Long 開始 = Worksheets("(1)(1)(1)(1)(1)").Range("F2").Value 開始経過時間 = DateDiff("n", CDate("9:00"), 開始) 開始目盛 = Int(開始経過時間 / 5) Worksheets("(2)(2)(2)(2)").Range("H2").Offset(, 開始目盛).Interior.ColorIndex = 8 If 開始 <= "11:00" And 終了 >= "12:00" Then 終了 = Worksheets("(1)(1)(1)(1)(1)").Range("G2").Value 終了経過時間 = DateDiff("n", CDate("9:00"), 終了) 終了目盛 = Int(終了経過時間 / 5) Worksheets("(2)(2)(2)(2)").Range("H2").Offset(, 終了目盛 - 12).Interior.ColorIndex = 8 Range(Range("H2").Offset(, 開始目盛), Range("H2").Offset(, 終了目盛 - 12)).Interior.ColorIndex = 8 Else 終了 = Worksheets("(1)(1)(1)(1)(1)").Range("G2").Value 終了経過時間 = DateDiff("n", CDate("9:00"), 終了) 終了目盛 = Int(終了経過時間 / 5) Worksheets("(2)(2)(2)(2)").Range("H2").Offset(, 終了目盛).Interior.ColorIndex = 8 Range(Range("H2").Offset(, 開始目盛), Range("H2").Offset(, 終了目盛)).Interior.ColorIndex = 8 End If End Sub ############################################################### 休憩時間のIfの処理がうまくいかなくて困っています・・・。 &とAndで変わったり(どちらもうまくいかず)、 ()をつけたりしても変わらず、そもそも根本的に 間違っているのか・・・。 よろしくお願いいたします。 (グラフの繰り返しの処理は未だ考え中で触っておりません)

  • エクセル VBA セルの色をSheet1とSheet2の両方を変えたいのですが・・・

    最近困っているところが表題の通りなのですが Sheet1のB2を右クリックするとB2のセルの色を変えて Sheet2のB2のセルも色を変えたいというものです。 現状で Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim Rng As Range, myRng As Range Dim RngA As Range, myRngA As Range Set Rng = Range("B3:W3,b7:w8,b12:w12,d13:w13,d17:w18,d22:w23") Set myRng = Intersect(Target, Rng) If myRng.Interior.ColorIndex = xlColorIndexNone Then myRng.Interior.ColorIndex = 37 Else If myRng.Interior.ColorIndex = 37 Then myRng.Interior.ColorIndex = 45 Else myRng.Interior.ColorIndex = xlColorIndexNone End If End If Cancel = True End Sub とここまではあるのですが、これをどう改造すればSheet2の同じセルの色もかわるのでしょうか? 宜しくお願いいたします

  • エクセルVBA 双方向での書式のリンク方法

    エクセルVBAにて双方向での書式のリンクをさせたいと考えています。 具体的にはセルの背景色の双方向リンク方法について教えていただきたいです。ここで双方向での背景色のリンクとは別々のシート上のセルの背景色をどちら側の変更であっても、もう一方に変更を反映させることです。 【シート1】 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Sheets("Sheet2").Range("$A$1").Value = Sheets("Sheet1").Range("$A$1").Value Sheets("Sheet2").Range("$A$1").Interior.ColorIndex = Sheets("Sheet1").Range("$A$1").Interior.ColorIndex End If End Sub 【シート2】 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Sheets("Sheet1").Range("$A$1").Value = Sheets("Sheet2").Range("$A$1").Value Sheets("Sheet1").Range("$A$1").Interior.ColorIndex = Sheets("Sheet2").Range("$A$1").Interior.ColorIndex End If End Sub 上記のコードを記述しています。値のリンクはできているのですが背景色のリンクがどうしてもうまくできません。どちらかの変更と同時にもう一方の背景色も変更されるようにするにはどうすればよいでしょうか? どんな方法でもかまいませんのでお詳しい方よろしくお願いします。

  • エクセルVBAの連続検索

    エクセルVBAで、textbox内に入力した参加者の名前を検索しチェックを入れる作業を行いたいです(集会の受付名簿用)。findnextを使っても無限にループするか、同姓の最初の一人しか検索できずに困っています。 Dim 検索セル As Range Dim 最初のセル As String Dim 次の候補 As Range 検索対象文字 = Range("h2").Value Set 検索セル = Range("a5:B100").Find(検索対象文字) If Not 検索セル Is Nothing Then 最初のセル = 検索セル.address Do 検索セル.Select Set 次の候補 = Range("a5:b100").FindNext(after:=検索セル) Loop Until 次の候補.address = 最初のセル End If 手直しをお願いしますTT

  • excel vba

    VBAに不慣れなので教えてください。 今下記のプログラム(A1セルで青色以外の文字を消去する)はA1セルのみを対象にしているのですが、 (1)セルをA1からA3までにする。 (2)処理対象をA1のある列を対象とするようにしたい。 各々どう手直しすればいいか。 プログラムtest Public Sub test() Dim r As Range Dim i, wk As String Set r = Range("A1") wk = "" For i = 1 To Len(r.Value) Debug.Print r.Characters(i, 1).Font.ColorIndex If r.Characters(i, 1).Font.Color = vbBlue Then wk = wk + r.Characters(i, 1).Text End If Next r.Value = wk r.Characters.Font.Color = vbBlue End Sub

専門家に質問してみよう