読者です 読者をやめる 読者になる 読者になる
スポンサーリンク

プロジェクトの用語集 テンプレート (検索ボックス付き Excel シート)

実行可能ドキュメント VBA ドキュメント excel 作品


開発チーム内で,用語を共有するためのxlsシート。

作っておけば,説明や引き継ぎがとても楽。


機能:

  • 検索ボックス(検索キーを含むセルの内容がリストアップされる。検索キーは斜体で表示される。)
  • シート一覧表示

ダウンロード
http://www.name-of-this-site.org/coding/vba/project_words.xls

使う際には入力用シートをコピーしていく。

コード

検索等のVBAのコードは下記のとおり。

Sub ボタン1_Click()
    Dim box_xpos As Integer
    Dim box_ypos As Integer
    Dim lngYLine As Long
    Dim intXLine As Integer
    Dim objFind As Object
    Dim strAddress As String
    Dim strKey As String
    Dim intFoundCnt As Integer
    Dim maxResults As Integer
    Dim i As Integer
    Dim strWSName As String
    Dim strAllSheets As String
    Dim splitedSheets As Variant
    Dim strSheet As Variant
    Dim tmpNaiyou As String
    Dim defWord As String
    ' 前回の検索結果を格納し、重複行を避ける
    Dim strSheet_pre As String
    Dim lngYLine_pre As Long
    
    box_xpos = 2
    box_ypos = 6
    strKey = Cells(box_ypos, box_xpos).Value
    intFoundCnt = 0
    maxResults = 19
 
    ' 有効な検索キーか
    If Len(strKey) < 1 Then
        Exit Sub
    End If
    
    ' 前回の結果
    strSheet_pre = ""
    lngYLine = 0
    
    ' シート一覧
    strAllSheets = allSheet()
    splitedSheets = Split(strAllSheets, ",")
    'MsgBox UBound(splitedSheets)
    For Each strSheet In splitedSheets
        'MsgBox (strSheet)
        If (ExistSheet(strSheet) = True) And _
            (StrComp(strSheet, "目次") <> 0) And _
            (StrComp(strSheet, "修正履歴") <> 0) Then
            
            ' シート設定
            strWSName = strSheet
            
            ' 検索
            Set objFind = Worksheets(strWSName).Cells.Find(strKey)
            If Not objFind Is Nothing Then
                strAddress = objFind.Address
                Do While Not objFind Is Nothing
                    ' 終了処理:MAX
                    If maxResults < intFoundCnt Then
                       Exit Do
                    End If
                    
                    ' 位置
                    lngYLine = objFind.Cells.Row
                    intXLine = objFind.Cells.Column
                    ' 無効化
                    If (lngYLine > 4) And _
                        Not ((StrComp(strSheet, strSheet_pre) = 0) And (lngYLine = lngYLine_pre)) Then
                        ' 結果表示
                         Cells(box_ypos + 3 + intFoundCnt, box_xpos - 1).Value = intFoundCnt + 1
                         Cells(box_ypos + 3 + intFoundCnt, box_xpos).Value = _
                            "=HYPERLINK(""#" + strSheet + "!" + "R" + CStr(lngYLine) + "C" + CStr(intXLine) + """," _
                               + " ""「" + strSheet + "」シート " + CStr(lngYLine) + "行目"" )"
                         ' 内容表示(隣のセル)
                         ' 定義セルか
                         tmpNaiyou = Worksheets(strWSName).Cells(lngYLine, intXLine)
                         defWord = Worksheets(strWSName).Cells(lngYLine, 2)
                         If intXLine = 2 Then
                            tmpNaiyou = defWord & " の定義行:"
                         Else
                            tmpNaiyou = defWord & " の説明: " & tmpNaiyou
                         End If
                         Cells(box_ypos + 3 + intFoundCnt, box_xpos + 2).Value = tmpNaiyou
                         ' フォント
                         ' 初期化
                         With Cells(box_ypos + 3 + intFoundCnt, box_xpos + 2)
                            .Font.Color = RGB(0, 0, 0)
                            .Font.Italic = False
                            .Font.Bold = False
                         End With
                         ' 検索キーの強調
                         With Cells(box_ypos + 3 + intFoundCnt, box_xpos + 2).Characters(InStr(tmpNaiyou, strKey), Len(strKey))
                            .Font.Italic = True
                            .Font.Bold = True
                         End With
                         ' 定義語の強調
                         With Cells(box_ypos + 3 + intFoundCnt, box_xpos + 2).Characters(1, Len(defWord))
                            .Font.Color = RGB(200, 50, 50)
                         End With
                         ' カウンタ
                         intFoundCnt = intFoundCnt + 1
                    End If
                    ' 前の結果を格納
                    strSheet_pre = strSheet
                    lngYLine_pre = lngYLine
                    ' 次を検索
                    Set objFind = Worksheets(strWSName).Cells.FindNext(objFind)
                                
                    ' 終了処理:空
                    If strAddress = objFind.Address Then
                        Exit Do
                    End If
                Loop
            End If
        End If
    Next
            
    ' なかった場合
    If intFoundCnt = 0 Then
        Cells(box_ypos + 3, box_xpos).Value = "見つかりませんでした"
    End If
    
    ' のこりのセルをクリア
    For i = intFoundCnt To maxResults
        Cells(box_ypos + 3 + i, box_xpos) = ""
        Cells(box_ypos + 3 + i, box_xpos + 2) = ""
    Next
End Sub


' ワークシート一覧
Function allSheet()

  Dim objSheet As Object
  Dim intLoop As Integer

  allSheet = ""
  intLoop = 0
  For Each objSheet In ActiveWorkbook.Sheets
    If intLoop = 0 Then
       allSheet = objSheet.Name
    Else
       allSheet = allSheet & "," & objSheet.Name
    End If
    intLoop = intLoop + 1
  Next

End Function


Function ExistSheet(SheetName) As Boolean
    '引数 SheetName のシートが実際にあるかチェックする
    
    Dim i, cnt As Integer
    
    cnt = Sheets.Count
    ExistSheet = False
    For i = 1 To cnt
        If Sheets(i).Name = SheetName Then
            ExistSheet = True
            Exit For
        End If
    Next
End Function


Sub ボタン7_Click()
    ' シート一覧を表示
    
    ' オフセット
    Dim ofy As Integer
    ofy = 34
    Dim ofx As Integer
    ofx = 2
    ' カウンタ
    Dim cntSheet As Integer
    cntSheet = 0
        
    ' シート一覧
    strAllSheets = allSheet()
    splitedSheets = Split(strAllSheets, ",")
    
    
    ' シート一覧
    strAllSheets = allSheet()
    splitedSheets = Split(strAllSheets, ",")
    For Each strSheet In splitedSheets
        If (ExistSheet(strSheet) = True) And _
            (StrComp(strSheet, "目次") <> 0) And _
            (StrComp(strSheet, "修正履歴") <> 0) Then
            ' リンク作成
            Cells(ofy + cntSheet, ofx - 1).Value = cntSheet + 1
            Cells(ofy + cntSheet, ofx).Value = "=HYPERLINK( ""#" + strSheet + "!A1"", """ + strSheet + """)"
            
            ' カウンタ
            cntSheet = cntSheet + 1
        End If
    Next
                    
End Sub


シート名をセルに表示させる所は,下記のサイトを参考にした。

http://www11.plala.or.jp/koma_Excel/contents1/mame1010/mame101001.html