子エンティティビューに親情報を表示する

子エンティティの一覧（ビュー）に、親エンティティの情報を表示できる　とのことです。

シナリオ:  * 部署エンティティと従業員エンティティがある
 * 部署対従業員は１対多
 * 部署エンティティにある代表電話を従業員エンティティの一覧に表示する

まず、部署フォームに、部署名と代表電話を追加する。

人事部と総務部とそれぞれの代表電話を登録する。



次に、従業員フォームに、氏名と所属を追加する。

従業員一覧をカスタマイズします。
下記列を追加する画面で、エンティティを選択できることがわかります。
そこに、親エンティティである部署「所属（部署）」という名前で表示されています。


所属（部署）を選択すると、部署エンティティの列を選択できます。ここで、代表電話を選択します。

こんなイメージで、従業員の一覧に、親エンティティである部署の代表電話が表示されます。

以上

カスタムボタンをフォームに追加する

DynamicsCrm2011では、ボタンは基本的リボンに配置しますが、複数参照入力など、ボタンをフォームに配置したいときがあります。

今回は、ボタンをフォームに配置する方法を紹介します。

手順：
1.SilverLightボタンを作成します。
2.作成されたボタンをWebリソースにアップロードします。
3.フォームカスタマイズ画面で、ボタンを追加します。

早速、ボタンはこんなイメージで追加されます。

管理者の右は追加されたボタン

詳細説明

1.SilverLightボタンを作成します。

ボタンを作成するため、以下ツールを使用します。
・VisualWebDeveloper2010 Express
・MicroSoft SilverLight4.0

ボタンの作成手順
1-1.Silverlightアプリケーションを作成します。
※プロジェクト名は「button」とします。

1-2.デフォルトページ（MainPage.xaml）に、SilverLightコントロールのボタンを追加します。

1-3.ボタン名を「カスタムボタン」と設定して、右の余白、上の余白をセロに設定します。

1-4.コンパイルします。
コンパイルが正常できたら、
...Visual Studio 2010\Projects\button\button\Bin\Debugに、
button.xapというファイルが作成されます。これがボタンです。

2.作成されたボタンをWebリソースにアップロードします。
button.xapをWebリソースにアップロードします。

3.フォームカスタマイズ画面で、ボタンを追加します。
任意のフォームカスタマイズ画面を開いて、リボンの追加タブのWebリソースで、ボタンを追加します。

アップロードされたボタン「new_custombutton」が選択候補
になっている

以上

インタネットデータを取得して一覧にするマクロ

製品のスペック、価格、メーカなどの情報をインタネットで調べて、一覧表に纏めたいときがあります。地道で手間のかかる作業です。今回は、この作業を半自動化するマクロを紹介します。

作業の流れは

1.WebページのURLを入手します

2.Webページをエクセルで開く

3.エクセルで開いたWebページのデータをファイルに出力します

4.出力されたファイルをもとに、一覧表を作成します

※作業の2～4はマクロがやってくれます。
※一覧表の作成はユーザ定義一覧を作成するマクロを使用します。

画面はこうなります。

画面の操作を紹介します。
1.URLを入力して、「取得」ボタンにて、インタネットデータを表示します。
※画面の８行目以降
2.Webページ全体を取得するのか、ページの中の表だけを取得するのかを指定できます。
2.出力パスボタンにて、ファイルの格納先を指定します。
3.ファイル名に値またはセルアドレスを指定します。ファイル名は「名前_日付」になります。
4.「ファイル出力」ボタンにて、現在表示しているWebデータをエクセルファイルに出力します。

ソースはこうなります。

''************************************************
'画面の「取得」ボタンから呼び出される
'************************************************
Sub GetWebData()

    Dim strUrl As String
    Dim intLastrow As Integer
    Dim strFileName As String
    Dim strPageType As String
 
    If Range("B1").Value = "" Then Exit Sub
 
    strUrl = Range("B1").Value
    strWebTable = Range("B2").Value
    strFileName = Range("B5").Value
 
    If Range("A2").Value = "表のみ" Then
        strPageType = xlAllTables
    Else
        strPageType = xlEntirePage
    End If
 
    intLastrow = Range("C10000").End(xlUp).Row
 
    '既存データをクリア
    If intLastrow > 8 Then
     
        ThisWorkbook.Sheets("GetWebData").Rows("8:" & intLastrow).Delete shift:=xlUp
 
    End If
 
    'Webデータをダウンロードする
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & strUrl, Destination:=Range("$C$8"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = strPageType
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
 
    Range("B5").Value = strFileName
 
End Sub

'************************************************
'画面の「ファイル出力」ボタンから呼び出される
'************************************************
Sub CreatWebDataFile()
    Dim objApp As Object     'Excelアプリ
    Dim objBook As Object    'ExcelBook
    Dim objSheets As Object  'ExcelSheets
    Dim strMsg As String     'エラーメッセージ
    Dim strWebDataFileName  As String  '保存Excelファイル
    Dim xlNormal As Integer
 
    Dim intLastrow As Integer

    xlNormal = -4143

    If Range("B4").Value = "" Then Exit Sub
    If Range("B5").Value = "" Then Exit Sub
    If Range("C8").Value = "" Then Exit Sub

    'フルパス付きファイル名
    strWebDataFileName = Range("B4").Value & "\" _
                         & Range("B5") & "_" & _
                         Format(Date, "yyyymmdd")

    intLastrow = Range("C10000").End(xlUp).Row
 
    On Error Resume Next
    Err.Clear

    Set objApp = CreateObject("Excel.Application")

    If Err Then
    'エラー処理
        strMsg = strMsg & "Excelを起動できませんでした" & vbCrLf
        strMsg = strMsg & "Err.Number:" & Err.Number & vbCrLf
        strMsg = strMsg & "Err.Description:" & Err.Description & vbCrLf
    End If

    If strMsg <> "" Then
     
        'エラーメッセージの表示
        MsgBox strMsg, vbCritical, "Excel の作成"
 
    Else
 
        '新規ワークシートを作成
        objApp.Workbooks.Add
     
        '非表示にする
        objApp.Application.Visible = False
     
        '確認ダイアログを表示させない
        objApp.DisplayAlerts = False
     
        Set objBook = objApp.ActiveWorkbook
        Set objSheets = objBook.Worksheets
     
        'シート1のみ残して後は削除
        For i = 2 To objSheets.Count
            objBook.Sheets(i).Delete
        Next
     
        'データをコピーする
        objSheets(1).Range("A1:X" & intLastrow - 8).Value = _
             ThisWorkbook.Sheets("GetWebData").Range("C8:Z" & intLastrow).Value
           
        '新規ブックを保存
        objBook.SaveAs Filename:=strWebDataFileName, _
                        FileFormat:=xlNormal, _
                        Password:="", _
                        WriteResPassword:="", _
                        ReadOnlyRecommended:=False, _
                        CreateBackup:=False

        'Excelの終了
        objApp.DisplayAlerts = True        '確認ダイアログを表示させる
        objBook.Close
        objApp.Quit
     
        'オブジェクトの解放
        Set objSheet = Nothing
        Set objSheets = Nothing
        Set objBook = Nothing
        Set objApp = Nothing
        'エラーメッセージの表示
        MsgBox "ファイルを作成しました。", vbInformation, "Excelの作成"

    End If

End Sub

----------

以上

ユーザ定義一覧表を作成するマクロ

複数のファイルから、特定のシートの特定のセルから値を抽出し、一覧表に纏めるマクロを紹介します。

画面はこうなります。

1.ファイル検索画面
対象ファイルを検索してから、「ユーザ定義一覧」にて、処理を始めます。

※埼玉県市区町村別の人口ファイル 

2.設定および処理結果一覧画面
抽出するシート名とセル名を指定します。セルは最大８つまで指定できます。

※市区町村別人口一覧の作成例 

ソースはこうなります。

'***************************************************
'画面の「ユーザ定義一覧」ボタンから呼び出される
'***************************************************
Sub UserDefineList()

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strFile As String
   
    Dim intRow As Integer
    Dim intLastRow As Integer
    Dim intLastTableRow As Integer
   
    Dim strCell1 As String
    Dim strCell2 As String
    Dim strCell3 As String
    Dim strCell4 As String
    Dim strCell5 As String
    Dim strCell6 As String
    Dim strCell7 As String
    Dim strCell8 As String

    If ThisWorkbook.Sheets(1).Range("D10").Value = "" Then Exit Sub
    If ThisWorkbook.Sheets("UserDefineList").Range("B2").Value = "" Then Exit Sub
 
    strCell1 = ThisWorkbook.Sheets("UserDefineList").Range("C2").Value
    strCell2 = ThisWorkbook.Sheets("UserDefineList").Range("D2").Value
    strCell3 = ThisWorkbook.Sheets("UserDefineList").Range("E2").Value
    strCell4 = ThisWorkbook.Sheets("UserDefineList").Range("F2").Value
    strCell5 = ThisWorkbook.Sheets("UserDefineList").Range("G2").Value
    strCell6 = ThisWorkbook.Sheets("UserDefineList").Range("H2").Value
    strCell7 = ThisWorkbook.Sheets("UserDefineList").Range("I2").Value
    strCell8 = ThisWorkbook.Sheets("UserDefineList").Range("J2").Value

    'ファイル一覧の最終行を求める
    intLastTableRow = ThisWorkbook.Sheets("UserDefineList").Range("B10000").End(xlUp).Row
 
    '既存の表のをクリアする
    intLastTableRow = ThisWorkbook.Sheets("UserDefineList").Range("B4").End(xlDown).Row
    If intLastTableRow > 4 Then
        ThisWorkbook.Sheets("UserDefineList").Range("B5:J" & intLastTableRow).Value = ""
        ThisWorkbook.Sheets("UserDefineList").Range("B5:J" & intLastTableRow).　_
                                                                    Borders.LineStyle = xlLineStyleNone
 
    End If

    '画面更新を無効にする
    Application.ScreenUpdating = False

 
    'メッセージ表示を無効にする
    Application.DisplayAlerts = False
 
    intRow = 4

    'ファイル毎の処理
    For i = 10 To intLastRow
   
        strFile = ThisWorkbook.Sheets(1).Cells(i, 4).Value

        If Right(strFile, 3) = "xls" Or Right(strFile, 4) = "xlsx" Then

            'ファイルをセットする
            Set objBook = Application.Workbooks.Open(strFile)
       
            'シート毎の処理
            For Each objSheet In objBook.Sheets
           
                If objSheet.Name = ThisWorkbook.Sheets("UserDefineList").Range("B2").Value Then
                 
                    intRow = intRow + 1
                 
                    ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 2).Value = objBook.Name
                 
                    '1列目
                    If strCell1 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 3).Value = _
                                                                       objSheet.Range(strCell1).Value
                    End If
                 
                    '2列目
                    If strCell2 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 4).Value = _
                                                                       objSheet.Range(strCell2).Value
                    End If
                 
                    '3列目
                    If strCell3 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 5).Value = _
                                                                       objSheet.Range(strCell3).Value
                    End If
                 
                    '4列目
                    If strCell4 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 6).Value = _
                                                                       objSheet.Range(strCell4).Value
                    End If
                 
                    '5列目
                    If strCell5 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 7).Value = _
                                                                       objSheet.Range(strCell5).Value
                    End If
                 
                    '6列目
                    If strCell6 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 8).Value = _
                                                                       objSheet.Range(strCell6).Value
                    End If
                 
                    '7列目
                    If strCell7 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 9).Value = _
                                                                       objSheet.Range(strCell7).Value
                    End If
                 
                    '8列目
                    If strCell8 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 10).Value = _
                                                                       objSheet.Range(strCell8).Value
                    End If
                 
             
                Exit For
                End If
             
            Next objSheet
         
            '表に罫線をかける
            ThisWorkbook.Sheets("UserDefineList").Range("B4:J" & intRow). _
                                                          Borders.LineStyle = xlContinuous
       
            'ファイルクローズ
            objBook.Close savechanges:=False
               
        End If
       
    Next i

    'メッセージ表示を有効にする
    Application.DisplayAlerts = True

    '画面更新を有効に戻す
    Application.ScreenUpdating = True

    'シート処理結果をアクティブにする
    ThisWorkbook.Sheets("UserDefineList").Activate

    ' 処理完了(結果表示)
    MsgBox "処理が完了しました。"

End Sub

----------
以上

複数エクセルファイルの取消文字列を一括削除するマクロ

仕様書の変更箇所を分かりやすくするために、変更履歴、取消線、文字色などが活用されています。やがて、文字色を統一し、変更履歴や取消線で消された文字を削除し、納品物に仕上げます。

今回ご紹介するマクロは
・セルの全部、または一部が取消線でマークされている文字列を削除します。
・処理結果を記録します。

画面はこうなります。

1.処理開始画面
処理対象ファイルを検索してから、一括削除する流れで操作します。
取消線でマークされた文字列を一セルずつ検索するので、セルの範囲を指定して、スピードアップをはかります。

2.処理結果画面

下図６列で処理結果を把握します。

ソースはこうなります。

'***************************************************
'画面の「取消文字を一括削除」ボタンから呼び出される
'***************************************************
Sub DelStrikeOutWords()

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strFile As String
   
    Dim intRow As Integer
    Dim intLastRow As Integer
   
    Dim intCount As Integer
    Dim celCell As Variant

    Dim chaChar As Characters
    Dim strResult As String
    Dim strDelWord As String
    Dim strRange As String

    If ThisWorkbook.Sheets(1).Range("D10").Value = "" Then Exit Sub

    '最終行を求める
    intLastRow = ThisWorkbook.Sheets(1).Range("D9").End(xlDown).Row

    '画面更新を無効にする
    Application.ScreenUpdating = False

    '削除処理の範囲
    strRange = ThisWorkbook.Sheets(1).Range("S2").Value

    intRow = 1
    ThisWorkbook.Sheets("List").Cells.Clear
    ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = "処理結果一覧"

    intRow = 2
    ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = "削除前"
    ThisWorkbook.Sheets("List").Cells(intRow, 2).Value = "削除文字"
    ThisWorkbook.Sheets("List").Cells(intRow, 3).Value = "削除後"
    ThisWorkbook.Sheets("List").Cells(intRow, 4).Value = "セル"
    ThisWorkbook.Sheets("List").Cells(intRow, 5).Value = "シート"
    ThisWorkbook.Sheets("List").Cells(intRow, 6).Value = "ファイル"


    'メッセージ表示を無効にする
    Application.DisplayAlerts = False

    'ファイル毎の処理
    For i = 10 To intLastRow
   
        strFile = ThisWorkbook.Sheets(1).Cells(i, 4).Value

        If Right(strFile, 3) = "xls" Or Right(strFile, 4) = "xlsx" Then

            'ファイルをセットする
            Set objBook = Application.Workbooks.Open(strFile)
       
            'シート毎の処理
            For Each objSheet In objBook.Sheets
         
                'セル毎の処理
                For Each celCell In objSheet.Range(strRange)

              　　 '数字だと、エラーになるので、文字列だけ処理する
                    If VarType(celCell.Value) = vbString Then
           
                      intCount = Len(celCell)
                      strResult = ""
                      strDelWord = ""
             
                      For j = 1 To intCount
                     
                          Set chaChar = celCell.Characters(j, 1)
                     
                          If chaChar.Font.Strikethrough Then
                       
                             strDelWord = strDelWord + chaChar.Text
                           
                          Else
                       
                            strResult = strResult + chaChar.Text
                         
                          End If
                     
                      Next j
                 
                      If Len(strDelWord) > 0 Then
                     
                          '削除対象文字の一覧を作成する
                          intRow = intRow + 1
                          ThisWorkbook.Sheets("List").Cells(intRow, 1).Value = celCell.Value
                          ThisWorkbook.Sheets("List").Cells(intRow, 2).Value = Trim(strDelWord)
                          ThisWorkbook.Sheets("List").Cells(intRow, 3).Value = Trim(strResult)
                          ThisWorkbook.Sheets("List").Cells(intRow, 4).Value = celCell.Row _
                                                               & "行" & celCell.Column & "列"
                          ThisWorkbook.Sheets("List").Cells(intRow, 5).Value = objSheet.Name
                          ThisWorkbook.Sheets("List").Cells(intRow, 6).Value = objBook.Name
                     
                          '削除後の文字をセットする
                          celCell.Value = Trim(strResult)
                 
                      End If
                 
                    End If
           
                Next celCell
       
            Next objSheet
       
            'ファイルクローズ
            objBook.Close savechanges:=True
               
        End If
       
    Next i

    'メッセージ表示を有効にする
    Application.DisplayAlerts = True

    '画面更新を有効に戻す
    Application.ScreenUpdating = True

    'シート処理結果をアクティブにする
    ThisWorkbook.Sheets("List").Activate

    ' 処理完了(結果表示)
    MsgBox "処理が完了しました。"

End Sub

-----------------------

以上

複数エクセルファイルから特定の単語を検索するマクロ

大量の仕様書から、今日変更された仕様書だけ知りたい。

横展開するとき、漏れのないように修正したい。

基本的なことですが、悩ましいことです。

次の二つのアプローチで、このような悩みを軽減したいと思います。

1.指定したフォルダ（サブフォルダ含む）にあるファイル、およびその更新日時を一覧化します。

→更新日時でソート書けば、いつどのファイルが変更されたのかはすぐ分かります。

2.特定のキーワードがどのファイルのどこに存在するかを一覧化します。

→横展開の範囲を知るための重要手がかりになります。


次のマクロは
・特定フォルダに格納されているファイルの一覧
・特定キーワードを含むファイルの一覧
を作ってくれます。

インタフェースはこうなります。
1.ファイル一覧


2.特定キーワードを使用するファイルの一覧

ソースコードはこうなります。



'***********************************************
'画面の「検索」ボタンから呼び出される
'***********************************************
Sub SearchWords()

    Dim intLastWordRow As Integer
    Dim intLastFileRow As Integer
    Dim intRow As Integer
 
    Dim strSearchType As String
    Dim strTargetWord As String
    Dim strFileName As String

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strAddress As String '開始セルアドレス
    Dim TargetCell As Range '検索目的セル
 
    Dim strWkWord As String
    Dim strWkCell As String
    Dim strWkFile As String
    Dim strWkSheet As String
 
 
    '完全一致・部分一致
    If ThisWorkbook.Sheets("SearchWord").Range("C1").Value = "完全一致" Then
        strSearchType = xlWhole
    Else
        strSearchType = xlPart
    End If
 
 
    'ファイル一覧の最終行
    intLastFileRow = ThisWorkbook.Sheets("FileList").Range("D9").End(xlDown).Row
 
    If ThisWorkbook.Sheets("FileList").Range("D10").Value = "" Then
        MsgBox "先にファイルを検索してください。"
        Exit Sub
    End If

 
    '単語一覧の最終行
    intLastWordRow = ThisWorkbook.Sheets("SearchWord").Range("A10000").End(xlUp).Row

    If intLastWordRow < 2 Then
        MsgBox "単語を指定してください。"
        Exit Sub
    End If


    '画面更新を無効にする
    Application.ScreenUpdating = False
 
    '既存の値をクリアする
    '既存検索結果一覧をクリア
    ThisWorkbook.Sheets("SearchWordResult").Cells.Clear
    ThisWorkbook.Sheets("SearchWordResult").Range("A1").Value = "検索結果"
    ThisWorkbook.Sheets("SearchWordResult").Range("A2").Value = "検索値"
    ThisWorkbook.Sheets("SearchWordResult").Range("B2").Value = "セル値"
    ThisWorkbook.Sheets("SearchWordResult").Range("C2").Value = "ファイル名"
    ThisWorkbook.Sheets("SearchWordResult").Range("D2").Value = "シート名"
    ThisWorkbook.Sheets("SearchWordResult").Range("E2").Value = "セルアドレス"

 
    'ファイル毎の処理
    For i = 10 To intLastFileRow
 
        strFileName = ThisWorkbook.Sheets("FileList").Range("D" & i).Value
     
        'エクセルファイルだけ検索する
        If Right(strFileName, 3) = "xls" Or Right(strFileName, 3) = "xlsx" Then
 
            Set objBook = Application.Workbooks.Open(strFileName)
         
            'シート毎の処理
            For Each objSheet In objBook.Sheets
         
                '単語毎の処理
             
                For j = 2 To intLastWordRow
             
                    strTargetWord = ThisWorkbook.Sheets("SearchWord").Range("A" & j).Value
                 
                    '一回目の検索
                    Set TargetCell = objSheet.Cells.Find(strTargetWord, LookAt:=
                                           _ strSearchType, MatchCase:=False, MatchByte:=False)
             
             
                    If Not TargetCell Is Nothing Then
                         
                        strAddress = TargetCell.Address
                        intRow = ThisWorkbook.Sheets("SearchWordResult").Range("A1").
                                     _ End(xlDown).Row
                         
                        Do
                            '見つかった場合の処理
                         
                            intRow = intRow + 1
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 1). _
                                 Value = strTargetWord
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 2). _
                                 Value = TargetCell.Value
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 3). _
                                 Value = objBook.Name
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 4). _
                                 Value = objSheet.Name
                            ThisWorkbook.Sheets("SearchWordResult").Cells(intRow, 5). _
                                 Value = TargetCell.Row & "行" & TargetCell.Column & "列"
                                     
                            '二回目以降の検索
                            Set TargetCell = objSheet.Cells.FindNext(TargetCell)
                             
                            '対象単語がないとき、または2回目当たったとき、ループから抜け出す
                            If TargetCell Is Nothing Then Exit Do
                            If TargetCell.Address = strAddress Then Exit Do
                             
                        Loop
                         
                    End If
             
             
             
                Next j
     
           Next objSheet
         
         
           '保存せず終了
            objBook.Close savechanges:=False
     
     
        End If
     

    Next i
 
 
    '画面更新を有効に戻す
    Application.ScreenUpdating = True
    ThisWorkbook.Sheets("SearchWordResult").Activate
 
 
    '検索結果一覧表を作成する
 
     'ヘッダー行の罫線と色
    ThisWorkbook.Sheets("SearchWordResult").Range("A2:E2").Borders.LineStyle = xlContinuous
    ThisWorkbook.Sheets("SearchWordResult").Range("A2:E2").Interior.ColorIndex = 20
 
    '検索値列の昇順でソートをかける
    If ThisWorkbook.Sheets("SearchWordResult").Range("A3") <> "" Then
     
        ThisWorkbook.Sheets("SearchWordResult").Range("A3:E" & intRow).Sort                  
                                           _ key1:=Range("A3:A" & intRow), order1:=xlAscending
 
        '重複値を除去し、罫線をかける
        strWkWord = ThisWorkbook.Sheets("SearchWordResult").Range("A3").Value
        strWkCell = ThisWorkbook.Sheets("SearchWordResult").Range("B3").Value
        strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C3").Value
        strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D3").Value
     
        For i = 4 To intRow
     
            '検索値列
            If ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = strWkWord Then
         
                ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = ""
         
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("A" & i - 1).Borders _
                                                                   (xlEdgeBottom).LineStyle = xlContinuous
                strWkWord = ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value
         
            End If
         
            'セル値列
            If ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value = strWkCell Then
         
                ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value = ""
         
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("B" & i - 1).Borders _
                                                                   (xlEdgeBottom).LineStyle = xlContinuous
                strWkCell = ThisWorkbook.Sheets("SearchWordResult").Range("B" & i).Value
         
            End If
         
            'ファイル名
            If ThisWorkbook.Sheets("SearchWordResult").Range("A" & i).Value = "" Then
         
                If ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = strWkFile Then
         
                    ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = ""
             
                Else
         
                    ThisWorkbook.Sheets("SearchWordResult").Range _
                          ("C" & i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                    strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value
             
                End If
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("C" & i - 1).Borders _
                                                                    (xlEdgeBottom).LineStyle = xlContinuous
                strWkFile = ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value
         
            End If
         
            'シート名
            If ThisWorkbook.Sheets("SearchWordResult").Range("C" & i).Value = "" Then
             
                If ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value = _
                    strWkSheet Then
                 
                    ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value = ""
             
                Else
                 
                    ThisWorkbook.Sheets("SearchWordResult").Range("D" & i - 1 & ":E" & _
                                                       i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                    strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value
             
                End If
            Else
         
                ThisWorkbook.Sheets("SearchWordResult").Range("D" & i - 1 & ":E" & _
                                                       i - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
                strWkSheet = ThisWorkbook.Sheets("SearchWordResult").Range("D" & i).Value
         
            End If

        Next i
 

        '列に罫線をかける xlEdgeTop xlEdgeBottom
        ThisWorkbook.Sheets("SearchWordResult").Range("A2:A" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("A2:A" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("C2:C" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("C2:C" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("E2:E" & _
                                               intRow).Borders(xlEdgeLeft).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("E2:E" & _
                                               intRow).Borders(xlEdgeRight).LineStyle = xlContinuous
     
        ThisWorkbook.Sheets("SearchWordResult").Range("A" & intRow & ":E" & _
                                               intRow).Borders(xlEdgeBottom).LineStyle = xlContinuous
        ThisWorkbook.Sheets("SearchWordResult").Range("A3:E" & intRow). _
                                               VerticalAlignment = xlTop
 
    End If

    ' 処理完了(結果表示)
 
    MsgBox "処理が完了しました。"

End Sub


--------------
以上

同一タスクで複数担当者を対応する「マイタスク」ビュー

ログインユーザが担当しているタスクを一覧表示するのがここでいう「マイタスク」ビューです。
同じタスクに、複数の担当者がいる場合の、「マイタスク」ビューの実現方法を紹介します。

次の業務要件を想定します。
・タスクは営業案件というエンティティに格納します。
・担当者はユーザというエンティティに格納します。

・一営業案件に、複数の担当者がいます。
・一担当者が、複数の営業案件を担当します。

・営業案件の担当者は画面で追加、または削除できるとします。
・「マイタスク」ビューで、ログインユーザが担当しているタスクを表示します。

実現手順は次の通りになります。

手順1：
営業案件とユーザのN:N関連付けを作ります。
※担当者というエンティティが自動的に作成されます。

手順2：

営業案件フォームに、担当者subグリッドを追加します。

出来上がったフォーム画面はこのようになります。

手順3：

マイタスクビューを作成します。

営業案件エンティティから、関連エンティティである担当者経由で、ユーザエンティティに辿り着き、

ユーザがログインユーザに等しいと設定します。

ここまで、作業完了です。次に、動作確認をします。

動作確認するためのデータを次のように作っておきます。

確認1：

担当者Aでログインする場合に、マイタスクビューに、営業案件１と営業案件２が表示されます。

確認2：

担当者Bでログインする場合に、マイタスクビューに、営業案件１だけ表示されます。

以上