Excel VBA質問箱 IV

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

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


16875 / 76732 ←次へ | 前へ→

【65320】Re:テキストボックスが7つあり、それに入力して検索するとデータを抽出するには?
質問  ろんろん  - 10/5/11(火) 15:49 -

引用なし
パスワード
   長いので2つに分けさせて頂きます。
本当に申し訳ございません。

frm Jyouken↓

'
'[キャンセル]ボタンがクリックされたときの処理
'
Private Sub cmdCancel_Click()

  ' 条件などを変更せずにユーザーフォームを隠す
  frmJyouken.Hide
  
End Sub


'
'[決定]ボタンがクリックされた場合の処理
'
Private Sub cmdKettei_Click()

  Dim Message As String
  Dim Seibetsu As String
  Dim MetaAddStr As String
  
  ' frmMainのラベルに表示する抽出条件のメッセージを作る
  Message = "抽出条件:"
  
  ' シート[抽出条件]の条件を記入するセルをクリア(空)にする
  Worksheets("抽出条件").Range("A2:G2").Clear
  
  ' 図書番号を抽出条件にした場合
  If chkTosyo.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtTosyo.Text)
    
    ' シート[抽出条件]のセルA2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "A2", MetaAddStr, cmbTosyoJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "図書番号に" & Chr(34) & txtTosyo & Chr(34) & "という" & cmbTosyoJyouken.Text
    
  End If
  
  ' タイトルを抽出条件にした場合
  If chkTitle.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtTitle.Text)
    
    ' シート[抽出条件]のセルB2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "B2", MetaAddStr, cmbTitleJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "タイトルに" & Chr(34) & txtTitle & Chr(34) & "という" & cmbTitleJyouken.Text
    
  End If
  
  ' 著者を抽出条件にした場合
  If chkTyosya.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtTyosya.Text)
    
    ' シート[抽出条件]のセルC2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "C2", MetaAddStr, cmbTyosyaJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "著者に" & Chr(34) & txtTyosya & Chr(34) & "という" & cmbTyosyaJyouken.Text
    
  End If
  
  ' 出版社を抽出条件にした場合
  If chkSyuppansya.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtSyuppansya.Text)
    
    ' シート[抽出条件]のセルD2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "D2", MetaAddStr, cmbSyuppansyaJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "出版社に" & Chr(34) & txtSyuppansya & Chr(34) & "という" & cmbSyuppansyaJyouken.Text
    
  End If
  
  ' 分野を抽出条件にした場合
  If chkBunya.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtBunya.Text)
    
    ' シート[抽出条件]のセルE2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "E2", MetaAddStr, cmbBunyaJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "分野に" & Chr(34) & txtBunya & Chr(34) & "という" & cmbBunyaJyouken.Text
    
  End If
  
  ' 分類を抽出条件にした場合
  If chkBunrui.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtBunrui.Text)
    
    ' シート[抽出条件]のセルF2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "F2", MetaAddStr, cmbBunruiJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "分類に" & Chr(34) & txtBunrui & Chr(34) & "という" & cmbBunruiJyouken.Text
    
  End If
  
  ' 棚番を抽出条件にした場合
  If chkTanaban.Value = True Then
  
    ' 検索文字として不適当な文字を変換する
    MetaAddStr = MetaCharCheck(txtTanaban.Text)
    
    ' シート[抽出条件]のセルG2に、選択肢の番号に従って
    ' 抽出条件を書き込む
    WriteJyoukenSheetString "G2", MetaAddStr, cmbTanabanJyouken.ListIndex
    
    ' frmMainに表示する抽出条件のメッセージを作成
    Message = Message & vbCrLf & "棚番に" & Chr(34) & txtTanaban & Chr(34) & "という" & cmbTanabanJyouken.Text
    
  End If
  ' メッセージができあがった時点で、frmMainのlblJyoukenに表示する
  frmMain.lblJyouken.Caption = Message
  
  ' 抽出条件が変更された場合、抽出表示モードを解除
  frmMain.tglCyuusyutsu.Value = False
  
  ' frmMainの[条件を満たすデータを抽出]ボタンにフォーカスを合わせる
  frmMain.tglCyuusyutsu.SetFocus
  
  ' 抽出条件を設定するユーザーフォームを隠す
  ' 隠しているだけなので、次回表示されたときは前回の設定値が保持されている
  frmJyouken.Hide
  
  ' シート[抽出条件]を表示する(確認用)
  Worksheets("抽出条件").Select
  
End Sub


Private Sub Label4_Click()

End Sub

' ユーザーフォームの閉じるボタンがクリックされたときの処理
'
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

  ' 閉じるボタンの操作で発生したイベントかどうかを調べる
  If CloseMode = vbFormControlMenu Then
    MsgBox ("[決定]か[キャンセル]ボタンをクリックしてください。")
    
    ' 引数Cancelに0以外(ここではTrue)を指定しプロシージャを
    ' 終了すると、ユーザーフォームを閉じる処理を無効化できる
    Cancel = True
    
  End If
  
End Sub


'
' 引数で指定された条件に従い、文字列の抽出条件式をシート[抽出条件]に書き込む
'
'  引 数:CellName(String型)  書き込むセル(A1形式であること)
'      StringValue(String型) 条件となる文字列
'      IndexNo(Integer型)   文字列の条件(シート[抽出条件]のIndexNoを参照)
'
Sub WriteJyoukenSheetString(CellName As String, StringValue As String, IndexNo As Integer)

  Dim SetStr As String
  
  ' 文字列系の条件の選択肢に応じて、抽出条件として指定する
  ' 文字列を作成する
  Select Case IndexNo
    Case 0       ' 文字列を含む
      SetStr = "*" & StringValue & "*"
      
    Case 1       ' 文字列から始まる
      SetStr = StringValue & "*"
      
    Case 2       ' 文字列と完全一致
      SetStr = StringValue
      
    Case Else
      MsgBox "コンボボックスで選ばれたListIndexの値が不正です。"
      Stop
      
  End Select
  
  ' ワークシートに条件式を書き込む
  Worksheets("抽出条件").Range(CellName).Value = SetStr
  
End Sub


' 検索用の文字として不適当なアスタリスク(*)と疑問符(?)が含まれる場合、
' メタキャラクタのチルダ(~)を付加するFunctionプロシージャ
'
'  引 数:SrcStr(String型)     検索用文字列
'  戻り値:MetaCharCheck(String型)  メタキャラクタを付加した検索文字列
'
Function MetaCharCheck(SrcStr As String) As String

  Dim i As Long
  Dim Moji As String
  Dim OutStr As String

  ' 空の文字列が指定された場合は何もせず空の文字列を返す
  If SrcStr = "" Then
    MetaCharCheck = ""
    Exit Function
  End If
  
  ' SrcStrの文字列中にアスタリスク(*)や疑問符(?)が含まれているか
  For i = 1 To Len(SrcStr)
    ' SrcStrを左から1文字ずつ取り出す
    Moji = Mid(SrcStr, i, 1)
    
    ' 取り出した文字がアスタリスク(*)または疑問符(?)ではないか
    If InStr("*?", Moji) <> 0 Then
      
      ' アスタリスク(*)や疑問符(?)の場合はメタキャラクタの
      ' チルダ(~)を付加する
      Moji = "~" & Moji
    
    End If
  
    ' 取り出した文字を1文字ずつ連結していく
    ' メタキャラクタを付加した場合は2文字追加となる
    OutStr = OutStr + Moji
  
  Next i
  
  ' 連結した文字列を戻り値とする
  MetaCharCheck = OutStr

End Function


↓標準モジュール

Sub シートからデータを抽出して表示()

  frmMain.Show vbModeless

End Sub

1 hits

【65319】テキストボックスが7つあり、それに入力して検索するとデータを抽出するに... ろんろん 10/5/11(火) 15:45 質問
【65320】Re:テキストボックスが7つあり、それに入力... ろんろん 10/5/11(火) 15:49 質問
【65322】Re:テキストボックスが7つあり、それに入力... Jaka 10/5/11(火) 17:17 発言
【65329】Re:テキストボックスが7つあり、それに入力... ろんろん 10/5/12(水) 11:49 質問
【65330】Re:テキストボックスが7つあり、それに入力... Jaka 10/5/12(水) 15:16 発言
【65339】Re:テキストボックスが7つあり、それに入力... ろんろん 10/5/13(木) 10:41 お礼
【65331】Re:テキストボックスが7つあり、それに入力... teian 10/5/12(水) 16:03 発言
【65340】Re:テキストボックスが7つあり、それに入力... ろんろん 10/5/13(木) 10:45 お礼
【65401】Re:テキストボックスが8つになったのですが ろんろん 10/5/18(火) 15:28 質問
【65404】Re:テキストボックスが8つになったのですが Jaka 10/5/18(火) 17:03 発言
【65406】Re:テキストボックスが8つになったのですが ろんろん 10/5/18(火) 17:12 お礼

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