プロジェクトの用語集 テンプレート (検索ボックス付き 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