Excel VBA質問箱 IV

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

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


53206 / 76736 ←次へ | 前へ→

【28349】Re:match関数について
回答  Hirofumi  - 05/9/2(金) 22:21 -

引用なし
パスワード
   色々と誤解が有るとまずいので整理します

例えば、以下の様な数表とします

sheet3上に表を作成
  A  B   C  D   E  F

2    あ   い  う   え  お
3 イ  100  120  140  160  180
4 ロ  110  140  160  180  200
5 ハ  120  160  180  200  220
6 二  130  180  200  220  240
7 ホ  140  200  220  240  260


A列3行目から下に、行見出し(イロハ・・)が有るとします
2行目、B2:F2に列見出し(あいう・・)が有るとします
数表のデータは、B3を先頭とします

次にUserFormの構成は、以下の様に成ります
ComboBox1 : 行見出しイロハ・・を表示し数表の行を指定
TextBox1 : 探索値を指定
TextBox2 : 探索結果を表示(例、ロ行、141の時、160を表示)
TextBox3 : 探索結果の有る列見だしを表示(例、ロ行、141の時、「う」)
TextBox4 : 探索結果の有る列位置を表示(例、ロ行、141の時、「D」)

UserFormのコードは以下の様に成ります

Option Explicit

Private rngListTop As Range
Private rngScope As Range

Private Sub ComboBox1_Change()

  Dim lngRow As Long
  Dim lngColumns As Long
  
  With ComboBox1
    'ComboBoxで有効な行が選択された場合
    If .ListIndex > -1 Then
      'ListIndexの値を保存
      'ListIndexの値と数表の行Offset値は等しい為
      lngRow = .ListIndex
    Else
      Exit Sub
    End If
  End With
  
  '選択された行の探索範囲を設定
  With rngListTop
    '列数を取得
    lngColumns = .Offset(lngRow, 256 - .Column).End(xlToLeft).Column - .Column + 1
    'この部分(以下4行)は、数表が有れば必要ないかも?
    If lngColumns <= 1 And .Value = "" Then
      MsgBox "参照データが有りません"
      Exit Sub
    End If
    '探索範囲を変数に代入
    Set rngScope = .Offset(lngRow).Resize(, lngColumns)
  End With
  
  TextBox1.Text = ""
  TextBox2.Text = ""
  TextBox3.Text = ""
  TextBox4.Text = ""
  
End Sub

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

  Dim lngFound As Long
  Dim lngOver As Long
  
  TextBox2.Text = ""
  
  With TextBox1
    If .Text <> "" Then
      '探索範囲から、値を探索
      lngFound = ColumnSearh(CLng(.Text), rngScope, lngOver)
      '探索が失敗した場合(探索値其の物が無い場合)
      If lngFound = 0 Then
        '探索値を超える最小値のある列が範囲内の場合
        If lngOver <= rngScope.Columns.Count Then
          '探索結果を表示(例、ロ行、141の時、160を表示)
          TextBox2.Text = rngScope(, lngOver).Value
          '探索結果の有る列見だしを表示(例、ロ行、141の時、「う」)
          TextBox3.Text = rngListTop.Offset(-1, lngOver - 1).Value
          '探索結果の有る列位置を表示(例、ロ行、141の時、「D列」)
          TextBox4.Text = GetColumnChr(rngListTop.Column + lngOver - 1) & "列"
        '範囲から外れる場合
        Else
          Beep
          MsgBox "参照値の範囲を超えています"
          Cancel = True
        End If
      '探索が成功した場合
      Else
        '探索結果を表示 (例、ロ行、141の時、160を表示)
        TextBox2.Text = rngScope(, lngFound).Value
        '探索結果の有る列見だしを表示(例、ロ行、141の時、「う」)
        TextBox3.Text = rngListTop.Offset(-1, lngFound - 1).Value
        '探索結果の有る列位置を表示(例、ロ行、141の時、「D列」)
        TextBox4.Text = GetColumnChr(rngListTop.Column + lngFound - 1) & "列"
      End If
    End If
  End With
  
End Sub

Private Sub UserForm_Initialize()

  Dim lngRows As Long
  Dim vntData As Variant
  
  '探索範囲の先頭セル位置を指定(Sheet3のB3を指定)
  Set rngListTop = Worksheets("Sheet3").Cells(3, "B")
  'ComboBoxのListを取得
  With rngListTop
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      MsgBox "参照データが有りません"
      Exit Sub
    End If
    '行見出し(イロハ・・)を取得
    vntData = .Offset(, -1).Resize(lngRows).Value
  End With
  
  'ComboBoxを設定
  With ComboBox1
    .List = vntData
'    .Style = fmStyleDropDownList
    .ListIndex = 0
  End With
  
End Sub

Private Sub UserForm_Terminate()

  Set rngListTop = Nothing
  Set rngScope = Nothing
  
End Sub

Private Function ColumnSearh(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long) As Long

  Dim vntFound As Variant
  
  'Matchによる二分探索
  vntFound = Application.Match(vntKey, rngScope, 1)
  'もし、エラーで無いなら
  If Not IsError(vntFound) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(, vntFound).Value Then
      '戻り値として、列位置を代入
      ColumnSearh = vntFound
    End If
    'Key値を超える最小値のある列
    lngOver = vntFound + 1
  Else
    lngOver = 1
  End If
  
End Function

Private Function GetColumnChr(lngMark As Long) As String
    
  Const clngAlphabet As Long = 26
  
  Dim lngNumb As Long
  Dim strColumn As String
  
  lngNumb = (lngMark - 1) \ clngAlphabet
  If lngNumb > 0 Then
    strColumn = Chr(64 + lngNumb)
  End If
  
  lngNumb = (lngMark - 1) Mod clngAlphabet
  
  GetColumnChr = strColumn & Chr(65 + lngNumb)
  
End Function

0 hits

【28222】match関数について KIKAKU 05/8/31(水) 15:44 質問
【28226】Re:match関数について ichinose 05/8/31(水) 16:42 発言
【28227】Re:match関数について KIKAKU 05/8/31(水) 17:33 お礼
【28233】Re:match関数について Hirofumi 05/8/31(水) 21:12 回答
【28238】Re:match関数について KIKAKU 05/9/1(木) 0:03 質問
【28242】Re:match関数について ichinose 05/9/1(木) 7:20 発言
【28273】Re:match関数について Hirofumi 05/9/1(木) 20:46 回答
【28275】Re:match関数について Hirofumi 05/9/1(木) 21:46 発言
【28305】Re:match関数について KIKAKU 05/9/2(金) 12:53 質問
【28311】Re:match関数について ichinose 05/9/2(金) 13:21 発言
【28340】Re:match関数について KIKAKU 05/9/2(金) 18:50 質問
【28354】Re:match関数について ichinose 05/9/3(土) 8:53 発言
【28365】Re:match関数について KIKAKU 05/9/3(土) 22:06 お礼
【28349】Re:match関数について Hirofumi 05/9/2(金) 22:21 回答

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