Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11397 / 13644 ツリー ←次へ | 前へ→

【15876】データ抽出について 初心者 04/7/9(金) 23:12 質問[未読]
【15879】Re:データ抽出について Asaki 04/7/9(金) 23:30 回答[未読]
【15886】Re:データ抽出について Asaki 04/7/10(土) 13:31 回答[未読]
【15881】Re:データ抽出について Hirofumi 04/7/10(土) 0:42 回答[未読]
【15890】Re:データ抽出について 初心者 04/7/10(土) 21:30 質問[未読]
【15891】Re:データ抽出について かみちゃん 04/7/10(土) 22:10 回答[未読]
【15892】Re:データ抽出について Hirofumi 04/7/10(土) 23:13 回答[未読]
【15898】Re:データ抽出について 初心者 04/7/11(日) 9:39 質問[未読]
【15901】Re:データ抽出について Hirofumi 04/7/11(日) 10:57 回答[未読]
【15902】別シートを次々処理したく Hirofumi 04/7/11(日) 11:31 回答[未読]
【15982】Re:別シートを次々処理したく 初心者 04/7/13(火) 21:26 質問[未読]
【15984】Re:別シートを次々処理したく Hirofumi 04/7/13(火) 21:59 回答[未読]
【16040】Re:別シートを次々処理したく Hirofumi 04/7/14(水) 21:40 回答[未読]
【16116】Re:別シートを次々処理したく 初心者 04/7/16(金) 20:48 お礼[未読]
【16207】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/20(火) 21:28 質問[未読]
【16208】Re:別シートを次々処理したく 以前の続き... Hirofumi 04/7/20(火) 21:59 発言[未読]
【16214】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/21(水) 6:30 発言[未読]
【16241】Re:別シートを次々処理したく 以前の続き... Hirofumi 04/7/21(水) 21:04 回答[未読]
【16309】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/24(土) 22:28 お礼[未読]
【15897】Re:データ抽出について @MS1 04/7/11(日) 9:28 発言[未読]

【15876】データ抽出について
質問  初心者  - 04/7/9(金) 23:12 -

引用なし
パスワード
   はじめまして。よろしくお願いします。

今、あるコードをもとに、別ブックから
商品名を引っ張ってきて、現在使用している
シートに表示したいと考えています。
ある行までコードが入っているのですが、
最初から最後まで、検索するにはどうすれば
よいのでしょうか?
(どの行までコードが入るか決まっておらず、
コードのあるものすべて商品名を表示させたい
のです)

**現在シート**         

コード  商品名

1
5
3
4


**参照シート**         

コード  商品名

1    りんご
2    ばなな
3    なし
4    すいか 
5    ぶどう
6    もも

↓データ抽出後

**現在シート**         

コード  商品名

1    りんご
5    ぶどう
3    なし
4    すいか

どなたかお知恵をお願いします。

【15879】Re:データ抽出について
回答  Asaki  - 04/7/9(金) 23:30 -

引用なし
パスワード
   こんばんは。

一般数式の VLookUp() ではダメなのでしょうか?

データがA1から入っているとして
B1=VLookUp(A1,参照シート!A$1:B$6,2)

【15881】Re:データ抽出について
回答  Hirofumi  - 04/7/10(土) 0:42 -

引用なし
パスワード
   各シートのレイアウトは、以下の様に成っているとします

**現在シート**
  A   B
1 コード 商品名
2  1
3  5
4  3
5  4

**参照シート**
   A    B
1  コード  商品名
2   1    りんご
3   2    ばなな
4   3    なし
5   4    すいか
6   5    ぶどう
7   6    もも

参照シートは、コードでソートされている物とします

以下を標準モジュールに記述して下さい

Option Explicit
Option Compare Text

Public Sub DataSearch()

  Const lngRowEnd As Long = 65536
  
  Dim i As Long
  Dim vntData As Variant
  Dim vntDataFile As Variant
  Dim blnExist As Boolean
  Dim strName As String
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim rngKyes As Range
  
  '"参照シート"の有るファイルを取得
  If Not GetReadFile(vntDataFile, _
          ThisWorkbook.Path, False) Then
    Exit Sub
  End If
  
  '画面更新の停止
  Application.ScreenUpdating = False
  
  strName = GetFileName(vntDataFile)
  With Workbooks
    For i = 1 To .Count
      If .Item(i).Name = strName Then
        blnExist = True
        Exit For
      End If
    Next i
    If blnExist Then
      .Item(strName).Activate
    Else
      '"参照シート"の有るファイルをOpen
      .Open (vntDataFile)
    End If
  End With
  'データを取得
  With Workbooks(strName).Worksheets("参照シート")
      vntData = Range(.Cells(2, "A"), _
      .Cells(lngRowEnd, "B").End(xlUp)).Value
  End With
  '入力ファイルをClose
  Workbooks(strName).Close
  
  'コードの有る範囲を設定
  With ThisWorkbook.Worksheets("現在シート")
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With
  'コードを配列に取得
  vntKeys = rngKyes.Value
  '結果用配列を確保
  ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 1)
  
  'コードの先頭から終りまで繰り返し
  For i = 1 To UBound(vntKeys, 1)
    'コードを探索
    vntResult(i, 1) = BinarySearch(vntKeys(i, 1), vntData)
  Next i
  
  '結果を出力
  With rngKyes
    .Offset(, 1).Resize(.Rows.Count).Value = vntResult
  End With
  
  Set rngKyes = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
    
End Sub

Private Function BinarySearch(vntKey As Variant, _
              vntScope As Variant) As Variant

'  二進探索

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  
  lngLow = LBound(vntScope, 1)
  lngHigh = UBound(vntScope, 1)
  
  Do While lngLow <= lngHigh
    lngMiddle = (lngLow + lngHigh) \ 2
    Select Case vntScope(lngMiddle, 1)
      Case Is < vntKey
        lngLow = lngMiddle + 1
      Case Is > vntKey
        lngHigh = lngMiddle - 1
      Case Is = vntKey
        lngLow = lngMiddle + 1
        lngHigh = lngMiddle - 1
    End Select
  Loop
  
  If lngLow = lngHigh + 2 Then
    BinarySearch = vntScope(lngMiddle, 2)
  Else
    BinarySearch = Empty
  End If
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "Excel File (*.xls),*.xls," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  
  GetFileName = Mid(strName, i + 1)
    
End Function

【15886】Re:データ抽出について
回答  Asaki  - 04/7/10(土) 13:31 -

引用なし
パスワード
   別のBookということを、読み飛ばしていました。m(_ _)m
両方のBookを開いた状態でVLookUp()を設定することで、可能なようです。

例えば、
>B1=VLookUp(A1,[Book1]参照シート!A$1:B$6,2)
Bookを閉じると、自動的にフルパスの参照になるようです。

【15890】Re:データ抽出について
質問  初心者  - 04/7/10(土) 21:30 -

引用なし
パスワード
   Hirofumi さん, Asakiさん

返信ありがとうございました。
vlookupなんですが、現在シートのコード順
がソートできない状況での作業になるので、
うまくいかない箇所がでてきて
しまうようです。
そこで、Hirofumi さんのコードを
参照させて頂いたところ、

'コードの有る範囲を設定
  With ThisWorkbook.Worksheets("現在シート")

の部分で”インデックスが有効範囲にありません”の
エラーがでるのですが、どう対処すれば
よいのでしょうか?

【15891】Re:データ抽出について
回答  かみちゃん  - 04/7/10(土) 22:10 -

引用なし
パスワード
   こんにちは。かみちゃん です。

横から失礼します。

> 'コードの有る範囲を設定
>  With ThisWorkbook.Worksheets("現在シート")
>
>の部分で”インデックスが有効範囲にありません”の
>エラーがでるのですが、どう対処すれば

「現在シート」という名前のシートがないのでは?
当方で確認する以上、正常に動作します。仮に「現在シート」という名前のシートを変更したら、同様なエラーが出ました。

【15892】Re:データ抽出について
回答  Hirofumi  - 04/7/10(土) 23:13 -

引用なし
パスワード
   このコードは、「現在シート」が有るBookにマクロが有る物として、書いています
因って、かみちゃんさんの言われる様に、マクロの有るBookに「現在シート」無い場合が考えられます
また、「現在シート」の有るBookとマクロの有るBookが違う場合、

  'コードの有る範囲を設定
  With ThisWorkbook.Worksheets("現在シート")

のThisWorkbookを、「現在シート」の有るBookに修正して下さい

【15897】Re:データ抽出について
発言  @MS1  - 04/7/11(日) 9:28 -

引用なし
パスワード
   横から失礼します。私も初心者ですが、気になった事があるので。
VLOOKUP関数を使う場合、現在シートのほうは別にコード順に
なっていなくてもかまわないですよね。また、どうやるにしても
現在シートをコード順にソートしたほうが処理的には速くなると
思います。そこで、ソートした後で処理をして最後に元の順番に
戻せばいいのなら、現在シートの商品名の右のほうの列に順番を
ふっておき、処理後にこの順番でソートし直すというのはだめで
すか?

**現在シート**         

コード  商品名  順番

1         1
5         2
3         3
4         4

【15898】Re:データ抽出について
質問  初心者  - 04/7/11(日) 9:39 -

引用なし
パスワード
   おはようございます。

皆さんが言っておられる通り、現在使用
しているシートにて、マクロを記入すると
正常に処理することができました。
ありがとうございます。

この現在使用しているシートのみでなく、
別シートを次々処理したく、
汎用的にいつでも、使えるようにしたい
のですが、そのようなことも可能でしょうか?
後からの質問で申し訳ないです。

【15901】Re:データ抽出について
回答  Hirofumi  - 04/7/11(日) 10:57 -

引用なし
パスワード
   >この現在使用しているシートのみでなく、
>別シートを次々処理したく、
>汎用的にいつでも、使えるようにしたい
>のですが、そのようなことも可能でしょうか?
>後からの質問で申し訳ないです。

マクロの有るBookと転記されるBook("現在シート"が有るBook)を別にしたいならこんなのでも善いかな?

  'コードの有る範囲を設定
  With ThisWorkbook.Worksheets("現在シート")
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With



  'コードの有る範囲を設定
  With ActiveSheet
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With

として、実行する時は、先ず、マクロの有るBookを開き、
次に"現在シート"が有るBookを開きます
次に、"現在シート"をActiveにして、マクロを実行します

尚、
>皆さんが言っておられる通り、現在使用
>しているシートにて、マクロを記入すると
>正常に処理することができました。
>ありがとうございます。
と有りますが、コードを記述するのは、シートのコードモジュールではなくて
必ず、標準モジュールに記述して下さい

【15902】別シートを次々処理したく
回答  Hirofumi  - 04/7/11(日) 11:31 -

引用なし
パスワード
   >この現在使用しているシートのみでなく、
>別シートを次々処理したく、

と言う事なら、発想を変えて、こんなのでも言いと思いますが?
今度は、以下のコードを「**参照シート**」の有るBookの標準モジュールに記述して下さい
まず、「**参照シート**」の有るBookを開きます
次に、処理したいBookを開き、処理したいシートをActiveにします
「DataSearch2」を実行します
処理したBookを閉じ、次に処理したいBookを開き同様にします

Option Explicit

Public Sub DataSearch2()

  Const lngRowEnd As Long = 65536
  
  Dim i As Long
  Dim rngData As Range
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim rngKyes As Range
  
  
  '画面更新の停止
  Application.ScreenUpdating = False
  
  'データ範囲を取得
  With ThisWorkbook.Worksheets("参照シート")
    Set rngData = Range(.Cells(2, "A"), _
        .Cells(lngRowEnd, "A").End(xlUp))
  End With
  
  'コードの有る範囲を設定
  With ActiveSheet
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With
  'コードを配列に取得
  vntKeys = rngKyes.Value
  '結果用配列を確保
  ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 1)
  
  'コードの先頭から終りまで繰り返し
  For i = 1 To UBound(vntKeys, 1)
    'コードを探索
    vntResult(i, 1) = RowSearchBin(vntKeys(i, 1), rngData)
  Next i
  
  '結果を出力
  With rngKyes
    .Offset(, 1).Resize(.Rows.Count).Value = vntResult
  End With
  
  Set rngKyes = Nothing
  Set rngData = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
    
End Sub

Private Function RowSearchBin(vntKey As Variant, _
            rngScope As Range) As Variant

  Dim vntFind As Variant
  Dim lngDataTop As Long
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      RowSearchBin = rngScope(vntFind, 2).Value
    End If
  End If
  
End Function

【15982】Re:別シートを次々処理したく
質問  初心者  - 04/7/13(火) 21:26 -

引用なし
パスワード
   Hirofumi さん, 皆様、いろいろな
ご意見ありがとうごおざいます。
返事が遅くなりました。

vlookupは、使用してみたのですが、
どうしても、ソートできない場合や、重複コード
が出る可能性があるため、なかなかうまく
いかなかったのです。

Hirofumi さん

ありがとうございます。ちゃんと、標準モジュール
に記述していますよ。

ちなみに、ファイルを一つに決めている場合、
毎回、ファイルを開くのは手間になるのですが、
どこを変えればいいのでしょうか?

【15984】Re:別シートを次々処理したく
回答  Hirofumi  - 04/7/13(火) 21:59 -

引用なし
パスワード
   >ちなみに、ファイルを一つに決めている場合、
>毎回、ファイルを開くのは手間になるのですが、
>どこを変えればいいのでしょうか?

どちらのコードで?、どのファイル?

先ず、「Sub DataSearch()」のコードで、
"参照シート"の有るファイルをを指定する場合

以下を削除

  '"参照シート"の有るファイルを取得
  If Not GetReadFile(vntDataFile, _
          ThisWorkbook.Path, False) Then
    Exit Sub
  End If

以下を削除した場所に追加
  
  'ファイルを指定する場合
  vntDataFile = "C:\My Documents\参照シート.xls"


次に、「Sub DataSearch2()」の場合は、余り必要無いかも?
必要とするなら?、ThisWorkbookのコードモジュールで

Private Sub Workbook_Open()

  '"現在シート"の有るファイルをOpen
  Workbooks.Open ("C:\My Documents\現在シート.xls")
  
End Sub

とすれば善いのでは?

【16040】Re:別シートを次々処理したく
回答  Hirofumi  - 04/7/14(水) 21:40 -

引用なし
パスワード
   もし、「Sub DataSearch()」を使うなら
現状では、「Sub DataSearch()」を実行する度に
「参照シート.xls」がOpenされてCloseされます
因って、「Sub DataSearch()」を以下の様に修正して下さい
この場合、最後の「続けて処理を行いますか?」に「はい」を答えた場合、
マクロの有るBookが閉じられるまでの間、「参照シート.xls」がOpenされなく成ります

Public Sub DataSearch()

  Const lngRowEnd As Long = 65536
  
  Dim i As Long
  Static vntData As Variant
  Dim vntDataFile As Variant
  Dim blnExist As Boolean
  Dim strName As String
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim rngKyes As Range
  
  
  'ファイルを指定する場合
'  vntDataFile = "C:\My Documents\参照シート.xls"
  vntDataFile = ThisWorkbook.Path & "\" & "VBATest397Data.xls"
  
  '画面更新の停止
  Application.ScreenUpdating = False
  
  'もし、参照用データが無いなら
  If VarType(vntData) <> vbArray + vbVariant Then
    strName = GetFileName(vntDataFile)
      With Workbooks
      For i = 1 To .Count
        If .Item(i).Name = strName Then
          blnExist = True
          Exit For
        End If
      Next i
      If blnExist Then
        .Item(strName).Activate
      Else
        '"参照シート"の有るファイルをOpen
        .Open (vntDataFile)
      End If
    End With
    'データを取得
    With Workbooks(strName).Worksheets("参照シート")
        vntData = Range(.Cells(2, "A"), _
          .Cells(lngRowEnd, "B").End(xlUp)).Value
    End With
    '入力ファイルをClose
    Workbooks(strName).Close
  End If
  
  'コードの有る範囲を設定
  With ActiveSheet
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With
  'コードを配列に取得
  vntKeys = rngKyes.Value
  '結果用配列を確保
  ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 1)
  
  'コードの先頭から終りまで繰り返し
  For i = 1 To UBound(vntKeys, 1)
    'コードを探索
    vntResult(i, 1) = BinarySearch(vntKeys(i, 1), vntData)
  Next i
  
  '結果を出力
  With rngKyes
    .Offset(, 1).Resize(.Rows.Count).Value = vntResult
  End With
  
  Set rngKyes = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  If MsgBox("処理が完了しました" & vbCrLf _
      & "続けて処理を行いますか?", _
        vbExclamation + vbYesNo + vbDefaultButton1, _
                  "配列の保持") = vbNo Then
    vntData = Empty
  End If
    
End Sub

【16116】Re:別シートを次々処理したく
お礼  初心者  - 04/7/16(金) 20:48 -

引用なし
パスワード
   Hirofumi さん:

いろいろありがとうございます。
今まで、困っていた処理が
スムーズにできるようになりました。

もっと、マクロの勉強をしてみます。

【16207】Re:別シートを次々処理したく 以前の続...
質問  初心者  - 04/7/20(火) 21:28 -

引用なし
パスワード
   ▼Hirofumi さん:

この間はありがとうございました。

この後、値段設定も行えればと思い、
コードを変えてみているのですが、
うまくいきません。

具体的には、C列に値段項目を追加しました。

結果出力箇所はこの部分を変えればよいとわかった
のですが、

'結果を出力
  With rngKyes
    .Offset(, 2).Resize(.Rows.Count).Value = vntResult
  End With

とってくるデータの場所(同じくC列からです)のコード
をどう変えればよいのでしょうか?

何度も申し訳ないですがお願いします。

【16208】Re:別シートを次々処理したく 以前の続...
発言  Hirofumi  - 04/7/20(火) 21:59 -

引用なし
パスワード
   >この後、値段設定も行えればと思い、
>コードを変えてみているのですが、
>うまくいきません。
>
>具体的には、C列に値段項目を追加しました。
>
>結果出力箇所はこの部分を変えればよいとわかった
>のですが、
>
> '結果を出力
>  With rngKyes
>    .Offset(, 2).Resize(.Rows.Count).Value = vntResult
>  End With
>
>とってくるデータの場所(同じくC列からです)のコード
>をどう変えればよいのでしょうか?

残念ながら、この部分だけの変更で修正できません
其処まで汎用性を考えて作っていませんので、どちらのコードも1行、2行の修正では出来ないと思います
時間が無いので、今すぐには出来ませんが考えて見ますが、
前にも書きましたが、どのコードでしょうか?
コードに因って修正方法が変わってきますので、それを教えて下さい

【16214】Re:別シートを次々処理したく 以前の続...
発言  初心者  - 04/7/21(水) 6:30 -

引用なし
パスワード
   ▼Hirofumi さん:

おはようございます。
お時間がないところ、申し訳ないです。

>前にも書きましたが、どのコードでしょうか?
>コードに因って修正方法が変わってきますので、それを教えて下さい

コードは、Datasearchの方を使いたいと思っています。

【16241】Re:別シートを次々処理したく 以前の続...
回答  Hirofumi  - 04/7/21(水) 21:04 -

引用なし
パスワード
   ☆印が追加するコード
★印が変更するコードです

Option Explicit

Public Sub DataSearch()

  Const lngRowEnd As Long = 65536
  
  Dim i As Long
  Static vntData As Variant
  Dim vntDataFile As Variant
  Dim blnExist As Boolean
  Dim strName As String
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim rngKyes As Range
  Dim lngFound As Long '☆追加
  
  'ファイルを指定する場合
  vntDataFile = "C:\My Documents\参照シート.xls"
  
  '画面更新の停止
  Application.ScreenUpdating = False
  
  'もし、参照用データが無いなら
  If VarType(vntData) <> vbArray + vbVariant Then
    strName = GetFileName(vntDataFile)
      With Workbooks
      For i = 1 To .Count
        If .Item(i).Name = strName Then
          blnExist = True
          Exit For
        End If
      Next i
      If blnExist Then
        .Item(strName).Activate
      Else
        '"参照シート"の有るファイルをOpen
        .Open (vntDataFile)
      End If
    End With
    'データを取得
    With Workbooks(strName).Worksheets("参照シート")
        vntData = Range(.Cells(2, "A"), _
          .Cells(lngRowEnd, "C").End(xlUp)).Value '★変更
    End With
    '入力ファイルをClose
    Workbooks(strName).Close
  End If
  
  'コードの有る範囲を設定
  With ActiveSheet
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With
  'コードを配列に取得
  vntKeys = rngKyes.Value
  '結果用配列を確保
  ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 2) '★変更
  
  'コードの先頭から終りまで繰り返し
  For i = 1 To UBound(vntKeys, 1)
    'コードを探索
    lngFound = BinarySearch(vntKeys(i, 1), vntData) '★変更
    If lngFound <> -1 Then '☆追加
      vntResult(i, 1) = vntData(lngFound, 2) '☆追加
      vntResult(i, 2) = vntData(lngFound, 3) '☆追加
    End If '☆追加
  Next i
  
  '結果を出力
  With rngKyes
    .Offset(, 1).Resize(UBound(vntResult, 1), _
      UBound(vntResult, 2)).Value = vntResult '★変更
  End With
  
  Set rngKyes = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  If MsgBox("処理が完了しました" & vbCrLf _
      & "続けて処理を行いますか?", _
        vbExclamation + vbYesNo + vbDefaultButton1, _
                  "配列の保持") = vbNo Then
    vntData = Empty
  End If
    
End Sub

Private Function BinarySearch(vntKey As Variant, _
              vntScope As Variant) As Long '★変更

'  二進探索

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  
  lngLow = LBound(vntScope, 1)
  lngHigh = UBound(vntScope, 1)
  
  Do While lngLow <= lngHigh
    lngMiddle = (lngLow + lngHigh) \ 2
    Select Case vntScope(lngMiddle, 1)
      Case Is < vntKey
        lngLow = lngMiddle + 1
      Case Is > vntKey
        lngHigh = lngMiddle - 1
      Case Is = vntKey
        lngLow = lngMiddle + 1
        lngHigh = lngMiddle - 1
    End Select
  Loop
  
  If lngLow = lngHigh + 2 Then
    BinarySearch = lngMiddle '★変更
  Else
    BinarySearch = -1 '★変更
  End If
  
End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  
  GetFileName = Mid(strName, i + 1)
    
End Function

【16309】Re:別シートを次々処理したく 以前の続...
お礼  初心者  - 04/7/24(土) 22:28 -

引用なし
パスワード
   ▼Hirofumi さん:

返信が遅くなりましたが、
追加事項のようになったにもかかわらず、
ありがとうございました。

11397 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free