• ベストアンサー

Excel 行番号を調べる

Excel で違うブックの表から 入力した文字と同じセルを調べ その隣のセルの文字を表示させたいのですが (検索するときはブックを開いておいてしてます。) lookupとかを使ってもなかなか上手く出来ず vbaを使って表示させようと思い 下のようなスクリプトを作ったのですが 別のブックの表が3万行ぐらいあるので for next でループさせていたら少し遅いので もう少し早くならないかと思っています。 machとかでぱっと行番号が解るようにしたいのですが 2日悩んだのですが、出来ませんでした。 で、皆様のお力を借りようと思い。 ご助力を宜しくお願いします。 Function slookup(Pno As Variant, bname As Variant, sname As Variant, Pli As Byte, searchli As Byte) As Variant Dim slow As Long Dim I As Long Dim lrow As Long On Error GoTo Fault: lrow = Workbooks(bname).Worksheets(sname).Range("A65536").End(xlUp).Row For I = 1 To lrow If Workbooks(bname).Worksheets(sname).Cells(I, Pli) = Pno Then slow = I Exit For End If Next I slookup = Workbooks(bname).Worksheets(sname).Cells(slow, searchli) If slookup = 0 Then slookup = "" 'スクリプトを抜ける Exit Function Fault: slookup = "" End Function

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

  • ベストアンサー
noname#70958
noname#70958
回答No.4

「最速」というわけではありませんが、 とりあえず「手軽でそこそこ速い」方法として。 ●ワークシート関数のMatchを使う '------------------------↓ ココカラ ↓------------------------ Function slookup2(Pno As Variant, bname As String, sname As String, Pli As Byte, searchli As Byte) As Variant  Dim slow As Long  Dim myRng As Range    On Error GoTo Fault:    With Workbooks(bname).Worksheets(sname)   Set myRng = .Range(.Cells(1, Pli), .Cells(65536, Pli).End(xlUp))   slow = Application.Match(Pno, myRng, 0)   slookup2 = .Cells(slow, searchli)  End With    Exit Function Fault:  slookup2 = "" End Function '------------------------↑ ココマデ ↑------------------------ ※ダミーデータを用いた実測ではオリジナルの60倍超のスピードで動作します。 ※Pnoは数値か文字列か判りませんからVariant型で良いのですが、  bname,snameはVariant型で取ると、   =slookup2(A2,$B$1,$C$1,1,2)  のようにブック名やシート名をセル参照する使い方ができないので不便かと思い、  String型に直しました。 Excel2000で動作確認。以上ご参考まで。

tsurezure24
質問者

お礼

おぉ、充分早いです。 ありがとうございます。 実は、Match私もやってみようとしたのですが、 Rangeの指定が間違ってました。 ありがとうございます。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (3)

  • lul
  • ベストアンサー率41% (10/24)
回答No.3

確かにFunctionでFindが上手く動かないですね…。 試しにFindの部分だけSubにしてFunctionからcallしてみましたがそれでもダメでした。。。 ところでうちの環境もOffice2000ですが、VLOOKUP使えましたよ。 =VLOOKUP(A1,[Book1.xls]Sheet1!$A$1:$B$12,2,TRUE) こんな感じで値を取得できました。 これでもやっぱり出来ませんか?

tsurezure24
質問者

補足

VLOOKUP 他のブックでも使えました でも、VLOOKUP関数って検索する列の 順番が正順でないと、ちゃんと検索してくれないみたいで やっぱりマクロでやってみます。

全文を見る
すると、全ての回答が全文表示されます。
  • lul
  • ベストアンサー率41% (10/24)
回答No.2

VLOOKUP関数だとご希望通りの事が出来ると思いますがどうですか? VBAでやるよりはお手軽ですよ。 "=VLOOKUP(検索値,範囲,列番号,検索の型)"

tsurezure24
質問者

補足

VLOOKUPでやってみたのですが 同じブック内なら出来るのですが 他のブックになるとエラーが出るのですが やっぱりExcelが古いからかな~ 今のは出来るのでしょうか?

全文を見る
すると、全ての回答が全文表示されます。
  • phoenix343
  • ベストアンサー率15% (296/1946)
回答No.1

VBAでやるんだったら Findメソッド使うほうが早いし、よほどラクだよ? Excel VBA 入門講座 (Find) http://excelvba.pc-users.net/fol7/7_1.html

tsurezure24
質問者

補足

やってみたのですが、 subプロシージャだと出来るのですが Functionプロシージャだと出来ないのですが 私のPCだけでしょうか? Excel2000だからかな~??

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • VBAで空白行を削除する

    VBAでリストの空白行を削除するための適当なコードを探しているのですがどんぴしゃのものが中々見つかりません。ご教授下さい。 ブックBのシートBのリストにはA2~AN●まで値が入っています。 別のブックAからVBAで値を取り出し貼り付けています。 いくつかの方法を試しました。 (1)ブックを開いたときに空白行を削除 Sub Auto_Open() '空白行を削除 Dim lRow As Long Dim i As Long lRow = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False For i = lRow To 2 Step -1 If Cells(i, 1).Value = "" Then Range(i & ":" & i).Delete End If Next i Application.ScreenUpdating = True End Sub 5分以上砂時計のままで結局終わりません。 強制終了させ再度ブックを開くと空白行は削除されているのですが、こんな動作では使うことができません。 (2)ブックAの値を貼り付けた後、空白行を削除し上書き保存する Sub エクスポート() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Range(Cells(5, 7), Cells(79, 46)).Select Selection.Copy 'コピー Workbooks.Open Filename:="\\パス\ブックB.xlsm" '貼り付け先ファイルオープン Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '貼り付け Dim lRow As Long Dim i As Long lRow = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False For i = lRow To 2 Step -1 If Cells(i, 1).Value = "" Then Range(i & ":" & i).Delete End If Next i Application.ScreenUpdating = True  '空白行を削除 ActiveWorkbook.Save '上書き保存 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub (3)空白行を削除の部分は以下のコードも試しました Worksheets("SheetB").Range("A1").Select Set currentCell = Worksheets("sheetB").Range("A1") Do While Not IsEmpty(currentCell) Set nextCell = currentCell.Offset(1, 0) If Not IsEmpty(currentCell) Then 'カレントセルが空白でなく、 If IsEmpty(nextCell) Then '次のセルが空白のとき nextCell.EntireRow.Delete End If End If Set currentCell = currentCell.Offset(1, 0) Loop '空白行削除 宜しくお願い致します。

  • 配列のフリーズを解消してください。

    Sub データ原本() Dim wsAll As Worksheet Set wsAll = Worksheets("All(5)") Dim lRow As Long, lCol As Long Dim i As Long, j As Long, cnt As Long With Worksheets("データ原本") '日付S行を日付に変更(「.」を「/」に置換) lRow = .Cells(Rows.Count, 1).End(xlUp).Row Dim MyArray As Variant MyArray = Range(.Cells(10, 1), .Cells(lRow, 1)) For i = 1 To lRow - 9 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/") Next Range(.Cells(10, 1), .Cells(lRow, 1)) = MyArray Erase MyArray '配列の初期化 '「天気」両サイドの &「内・外」両サイドの空白スペースを削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row MyArray = Range(.Cells(10, TNK), .Cells(lRow, TNK)) For i = 1 To lRow - 9 MyArray(i, 1) = Trim(MyArray(i, 1)) Next Range(.Cells(10, TNK), .Cells(lRow, TNK)) = MyArray Erase MyArray '配列の初期化 '数値0のデータ行の行削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(9, Columns.Count).End(xlToLeft).Column Dim arr_A As Variant, arr_B As Variant arr_A = Range(.Cells(9, 1), .Cells(lRow, lCol)).Value ReDim arr_B(1 To lRow - 8, 1 To lCol) cnt = 0 For i = 1 To lRow - 8 If arr_A(i, 18) <> 0 Then cnt = cnt + 1 For j = 1 To lCol arr_B(cnt, j) = arr_A(i, j) Next j End If Next i .Range("A9").Resize(lRow, lCol).Value = arr_B End With End Sub  上記のコードを2回実行すると2回目には、 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/")のところで「型が一致しません。」とフリーズします。かと言って 「 '数値0のデータ行の行削除」コードを一括削除して、実行ボタンを何度押してもフリーズすることはありません。どこに不具合が生じているのかわからないのですが、どなたか名回答を宜しくお願いします。

  • エクセルのマクロ

    下記のマクロを実行するといつも.Findのところでフリーズしてしまいます。 同じ方法で違うBookからの取込には不具合はないのですが、何故だかわかりません。 ちょっと長くなりますが、どなたか教えてください。 'Function fn_KAKUNIN_Update(strSheetName As String, strInBookName As String) '変数宣言 Dim wksInSheet As Worksheet '入力シート Dim wkbInBook As Workbook '入力ブック Dim wksUpSheet As Worksheet '更新するシート Dim lngKAKUNIN_MaxRow As Long Dim lngSYACHO_MaxRow As Long Dim intMsg As Integer Dim strGenbaNo As String Dim i As Long Dim j As Long Dim rngFind As Range Dim lngStrNo As Long Set wkbInBook = Workbooks(strInBookName) Set wksInSheet = wkbInBook.Worksheets Set wksUpSheet = Workbooks(pstrBookName).Worksheets(strSheetName) fn_KAKUNIN_Update = 1 lngKAKUNIN_MaxRow = wksInSheet.Range("C4").CurrentRegion.Rows.Count lngSYACHO_MaxRow = wksUpSheet.Range("H4").CurrentRegion.Rows.Count lngStrNo = 4 For i = lngStrNo To lngSYACHO_MaxRow strGenbaNo = wksUpSheet.Range("H" & i) With wksInSheet.Range("C4:C" & lngKAKUNIN_MaxRow) Set rngFind = .Find(strGenbaNo, LookIn:=xlValues, MatchCase:=False) If rngFind Is Nothing Then Else

  • VBAで複数行の指定

    VBA教えてください  初心者です やりたい事 for next文を使用しbook1のシート内N~R行にある文字が入っていたなら book2のシート内のB行の文字を消すといった内容です 考えたコード sub test() dim c as variant dim i as long Set c = Workbooks("book2.xls").ActiveSheet With Workbooks("book1.xls").ActiveSheet For i = 1 To 100 If .Cells(i, 14) Like "*受入*" Then 'もし、14行目のセルのどれかに『受入』という文字が入っていたら c.Cells(i, 2).Clear 'その2行の条件に当てはまるセルをクリアする End If Next i End With end sub これではbook1のシートに内のN行しか反映されません 複数行N~Rに反映させるコードわからないです 教えてもらえるとすごく助かります。

  • VBA一定の範囲内からデータが入っている行を検索

    現在VBAにて作成中です。 内容は、各シートの全く同じ範囲内から1シートへ自動で貼り付けを行い日付順に並べ替えるということです。 各シートは全て同じ表になっていますので、コピー範囲のセル番地は全シート同じです。 コピー範囲は、BF4:BM81で、BF4に日付が入っています。 81行までありますが、82行には、合計行が入っていることや、その下行もデータが入っている為、範囲指定をしています。また、81行設けていますが、上から順にデータは入っているものの、81行まで全て埋まっているとは限りません。 その為、下記のVBAにすると、各シートの81行までのデータが反映され1シートに全てのシート分が貼り付けられるので、かなりの行数になり、空白や0の行が出てしまいます。 範囲内から日付(列BF)のデータが入っている行までを検索し選択、貼り付けを行えるようにしたいと思っています。 どなたかご教授頂ければと思いますのでよろしくお願い致します。 見よう見まねで下記を作成しました。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow4 As Long Application.ScreenUpdating = False '----全データシートの有無をチェックします sh_check '----列見出しをコピーします Worksheets(2).Range("bf1:bm3").Copy Worksheets(1).Range("A1") For i = 2 To Worksheets.Count With Worksheets(i) 左上 = "Bf4" 右下 = "bm81" 範囲 = 左上 & ":" & 右下 lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(58, Columns.Count).End(xlToLeft).Column '----シートのデータが4行以上の場合にコピーします If lRow >= 4 Then lRow4 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 .Activate Range(範囲).Select Selection.Copy Worksheets(1).Cells(lRow4, 1).PasteSpecial Paste:=xlPasteValues End If End With Next i End Sub 説明に不足がありましたら、追って書き込みさせていただきます。

  • EXCEL コンボボックスのリスト設定

    リストインデックスが複数ある場合は動くのですが、 インデックスが0 もしくは1個しかない場合は、どのように処理を追加したらいいでしょうか。。 実行時エラー381 Lisプロパティを設定できません。プロパティの配列のインデックスが無効です、と メッセージが出ます。 いろいろ試してるのですがわかりません。 コンボボックスの値は別シートで参照先を指定しています。 ----------- Private Sub ComboBox3_DropButtonClick() Dim lRow As Long Dim i As Long, myCnt As Long Dim myData With Worksheets("部門名") lRow = .Range("O" & Rows.Count).End(xlUp).Row ’O列の最終行を確認 myData = .Range("O2:O" & lRow).Value ’コンボボックスのリストデータ End With With ComboBox3 .ColumnCount = 1 .ColumnWidths = "50" .List = myData End With End Sub

  • Excel VBAで別ブックのマクロから配列を取る

    Excel VBAで別ブックのマクロで計算した結果を配列で渡したいのですが、上手い方法が見つかりません。 同じブック内であれば、 Function GetAry(Imax As Integer, ByRef MyAry As Variant) as Boolean のような関数を作れば、GetAry = True の時に返値の MyAry が有効であるという判断ができますが、この関数を別ブックから使う場合は、参照渡しができません。 これはVBAの仕様なので仕方ないとして、以下のようなマクロを組んでみました。 '------------------------------------------------------- ' Book1.xlsm(呼び出される側) '------------------------------------------------------- Function MyAry(Imax As Integer) As Variant Dim i As Integer Dim SubAry() As Variant If Imax > 10 Then MyAry = False Else For i = 1 To Imax ReDim Preserve SubAry(i) SubAry(i) = i Next MyAry = SubAry End If End Function '------------------------------------------------------- ' Book2.xlsm(呼び出す側) '------------------------------------------------------- Sub GetMyAry() Dim DataAry As Variant Dim Imax As Integer Imax = 11 DataAry = Application.Run("Book1!MyAry", Imax) If DataAry <> False Then MsgBox UBound(DataAry) Else MsgBox DataAry End If End Sub '------------------------------------------------------- Imax = 11 であれば、メッセージボックスに False が表示されますが、Imax = 10 だと当然ですが「型が一致しません」というエラーになります。 エラートラップで誤魔化そうかとも思ったのですが、もっとスマートな方法がないでしょうか。 よろしくお願いします。

  • エクセル マクロで行削除のコードについての質問です

    ある指定のセル範囲が空白ならその行自体を削除したいですが 上手くいきません。 記述したコードは以下の通りです。 Sub A01() Dim IRow As Long Dim d As Variant, i As Variant d = InputBox("抽出する日数を入力してください", "日数") If d = "" Then Exit Sub lRow = Cells(Rows.Count, 1).End(xlUp).Row For i = lRow To 2 Step -1 If ActiveSheet.Range(Cells(i, 5), Cells(i, d)) = Empty Then ActiveSheet.Rows(i).EntireRow.Delete End If Next End Sub Ifの判定の部分でエラーが出ます。 どう修正したらよいかご教示願います。

  • Excel マクロでL2から空白行までを各々コピー

    Excel2003、OSはXPを使っています。 コピー元はブックAのL2からスタートして1行ずつをコピーし コピー先はブックBのC12からスタートして10行飛ばしでペーストする。 コピー元のL列に空白セルが来たらやめたいと考えています。 具体的には コピー元 -> コピー先 ブックA --> ブックB Sheet1 --> Sheet1 L2 ------> C12 L3 ------> C22 L4 ------> C32 ・ ・ コピー元に空白セルが来たらやめる といったイメージです。 初めてまだ3日程度なのでお恥ずかしいのですが、 以下のようなコードを作りましたが、a=の行で 「実行時エラー'9' インデックスが有効範囲にありません。」 と出てしまいます。 Dim a As Long Dim dc As Long Dim dct As Long a = Worksheets(bbk).Range("L2").End(xlDown).Rows '←実行時エラー'9' For dc = 2 To a For dct = 12 To dc + 10 Workbooks("ブックA.xls").Worksheets("Sheet1").Range("L" & dc).Copy _ Workbooks("ブックA.xls").).Worksheets("Sheet1").Range("C" & dct) Next dct Next dc 恐らく他にも悪いところはあるかと思いますが、 どうかご教授をおねがいします。

  • EXCEL VBA4行毎に枠で囲みたい

    お世話になります。 添付の様な表1があります。 これを表2のようにA1から順に4行毎に枠で囲みたいのです。 下記のようなコードを見よう見まねで書いてみましたがうまく動きません。 ごなたかご教授いただけませんでしょうか? よろしくお願い致します。 Dim i As Long Dim j As Long Dim lngYCnt As Long Dim intXCnt As Long Dim LastRow As Long ingYCnt = Worksheets("Sheet1").UsedRange.Rows.Count intXCnt = Worksheets("Sheet1").UsedRange.Columns.Count LastRow = Cells(Rows.Count, 1).End(xlUp).Row With Selection For i = 5 To LastRow Range("A" & i & ":F" & j).Select Selection.BorderAround Weight:=xlMedium j = j + 5 i = i + 5 Next End With どなたかご教授いただけませんでしょうか? よろしくお願い致します。 環境 EXCEL2003 WINDOWS XP SP3

専門家に質問してみよう