エクセル座標設定

Coordinate

Option Explicit

'※※※超重要※※※
'クラスCoordinateを呼び出した直後、点を反映させたいシートをアクティブにしてあげなければならない。
'他のモジュールまたはプロシージャでシートを選択してた場合、最後に選択されたシートの行列および縮尺を基準として点の位置が決定されてしまう。
'よって、このコードの最初の行で ～.Activate と宣言しなければならない。
'このマクロの場合、クラスDXT内でSheet3.Activateが宣言されているため、初期処理でSheet1.Activateを宣言する必要がある。

Public Sub Set_Coord(Xmm_Sta, Ymm_Sta, Xmm_End, Ymm_End, Zmm_Sta, Zmm_End As Double, _
                     lineFlag, graphicFlag As Boolean, _
                     graphicRGB, lineRGB, No As Long)

    Dim Xpt_Sta, Ypt_Sta, Xpt_End, Ypt_End, Zpt_Sta, Zpt_End As Double
    Dim mmArray, ptArray, zArray As Variant
    Dim convNo As Long 'mm→ptへ変換する順決変数
    Dim PtConv, ClearVars As Object
        
'初期処理
    Sheet1.Activate
    mmArray = Array(Xmm_Sta, -1 * Ymm_Sta, Xmm_End, -1 * Ymm_End)
    ptArray = Array(Xpt_Sta, -1 * Ypt_Sta, Xpt_End, -1 * Ypt_End)
    'zArray = Array(Zmm_Sta, Zpt_End)
    
'本処理
    For convNo = 0 To 3 'XYを変換する
        Set PtConv = New PointConversion
        Select Case convNo
            Case 0, 2 'Xを変換する
                ptArray(convNo) = PtConv.Pt_Conv(mmArray(convNo), Xmm_ActualSize, Xpt_Length, Xpt_Min, Xmm_Max, Xpt_Max, Xmm_0)
            Case 1, 3 'Yを変換する
                ptArray(convNo) = PtConv.Pt_Conv(mmArray(convNo), Ymm_ActualSize, Ypt_Length, Ypt_Min, Ymm_Max, Ypt_Max, Ymm_0)
        End Select
        
        If Zmm_End = 0 Then GoTo Skip 'Z軸に値があればZを変換する
            'Debug.Print "Zpt_End" & "= (" & Zmm_End & " " & Zmm_ActualSize & " " &  Zpt_Max & " " & Zpt_Min & " " & Zmm_ActualSize & " " & Zpt_Max & "  " & 0 & " )"
            Zpt_End = PtConv.Pt_Conv(Zmm_End, Zmm_ActualSize, Zpt_Max, Zpt_Min, Zmm_ActualSize, Zpt_Max, 0)
            If ptArray(convNo) = Xpt_Max Then ptArray(convNo) = ptArray(convNo) - Zpt_End + zMerge
            If ptArray(convNo) = Ypt_Max Then ptArray(convNo) = ptArray(convNo) - Zpt_End + zMerge
            If ptArray(convNo) = Xpt_Min Then ptArray(convNo) = ptArray(convNo) + Zpt_End - zMerge
            If ptArray(convNo) = Ypt_Min Then ptArray(convNo) = ptArray(convNo) + Zpt_End - zMerge
Skip:
         ptArray(convNo) = WorksheetFunction.Round(ptArray(convNo), 2) '四捨五入する
    Next convNo
    
'終了処理
    If lineFlag = True Then
        Call DebugPrintFile(No & "点目 線始点座標(" & ptArray(0) & " , " & ptArray(1) & ")" & vbLf & No & "点目 線終点座標(" & ptArray(2) & " , " & ptArray(3) & ")" & vbLf)
        Call Line_OBJ(ptArray(0), ptArray(1), ptArray(2), ptArray(3), lineRGB)  '線を引く
    End If
    
    If graphicFlag = True Then
    Call DebugPrintFile(No & "点目mm座標(" & Xmm_End & " , " & Ymm_End & ")" & vbLf & No & "点目pt座標(" & ptArray(2) & " , " & ptArray(3) & ")" & vbLf)
    Call Graphic_OBJ(ptArray(2), ptArray(3), graphicRGB) '点・図を置く
    End If

End Sub

Private Sub Line_OBJ(Xpt_Sta, Ypt_Sta, Xpt_End, Ypt_End, lineRGB)
    
    Sheet1.Range("A1").Select 'アクティブセルをA1に置いて謎セル削除を回避
    ActiveCell.Activate
    '線の図形オブジェクトを生成
    With Sheet1.Shapes.AddLine(Ypt_Sta, Xpt_Sta, Ypt_End, Xpt_End).Line
        .ForeColor.RGB = lineRGB
        .Weight = weightOfLine
    End With
    
End Sub
    
    
Private Sub Graphic_OBJ(Xpt_End, Ypt_End, graphicRGB)

    Sheet1.Range("A1").Select 'アクティブセルをA1に置いて謎セル削除を回避
    ActiveCell.Activate
    '丸や四角の図形オブジェクトを生成
    Ypt_End = Ypt_End - (objLength / 2)
    Xpt_End = Xpt_End - (objLength / 2)
    With Sheet1.Shapes.AddShape(msoShapeOval, Top:=Xpt_End, Left:=Ypt_End, Width:=objLength, Height:=objLength)
        .Fill.ForeColor.RGB = graphicRGB
        .Select
    End With
    '枠線を太さ0.25の黒色に設定
    With Selection.ShapeRange.Line
        .Weight = 0.25
        .ForeColor.RGB = 0
    End With
    
End Sub

Delete

Option Explicit

Sub Delete_OBJ()

    Application.ScreenUpdating = False
    Sheet1.Activate
    Sheet1.Range("A1").Select
    ActiveCell.Offset(0, 0).Activate
    Sheet1.Shapes.SelectAll
    Selection.Delete
    Sheet3.Activate
    Application.ScreenUpdating = True

End Sub

DXT

Option Explicit

Sub Data_Extract(countData, lineFlag, graphicFlag, classNo)
    
    Dim Xmm_Sta, Ymm_Sta, Zmm_Sta, Xmm_End, Ymm_End, Zmm_End As Double
    Dim SetCoord, DeleteOBJ, ClearVars As Object
    Dim pointErr, pErr_X, pErr_Y, pErr_Z, lineErr, lErr_X, lErr_Y, lErr_Z As Variant
    Dim dataExtractSheet, dataSheet As Worksheet
    Dim staRow, maxRow, cnt, repeat, graphicRGB, lineRGB, No As Long
    Dim criteriaCell As String
    Dim errStop As Boolean
    
'初期処理
    temporaryStorage = lineFlag
    Set dataSheet = Sheet3
    Set dataExtractSheet = Worksheets.Add
    Sheet3.Activate
    Range(countData).Select
    Selection.Copy dataExtractSheet.Range("A1")         'シート「プロットデータ」からデータを抽出する
    cnt = dataExtractSheet.Cells(1, 1).End(xlDown).Row  '抽出した表を元にデータ数を数える(タイトルも含まれるため-1すること)
'    Debug.Print cnt - 1 & "個のデータを抽出しました。"
    
'本処理
    For staRow = 2 To cnt 'タイトルの下から始めるため2からループ
    '点座標エラー判定
    pointErr = Array(pErr_X, pErr_Y, pErr_Z)
    pointErr(0) = dataExtractSheet.Cells(staRow, 4) 'D2～Dcnt
    pointErr(1) = dataExtractSheet.Cells(staRow, 5) 'E2～Ecnt
    pointErr(2) = dataExtractSheet.Cells(staRow, 6) 'F2～Fcnt
    '線座標エラー判定
    lineErr = Array(lErr_X, lErr_Y, lErr_Z)
    lineErr(0) = dataExtractSheet.Cells(staRow, 7) 'G2～Gcnt
    lineErr(1) = dataExtractSheet.Cells(staRow, 8) 'H2～Hcnt
    lineErr(2) = dataExtractSheet.Cells(staRow, 9) 'I2～Icnt
    
    For repeat = 0 To 2
        Select Case repeat
        Case 0, 1  'エラー(セルが「-」)なら点もしくは線を反映させない
            If pointErr(repeat) = "-" Then
                pointErr(repeat) = 0 'セルの「-」を強制的に0にする
                If oneTimeMsgFlg = False Then           'メッセージを一回のみ表示させるIf文
                   MsgBox "【" & classNo & " ：報告】" & vbLf & "XまたはY座標の値に「-」が含まれています。" & vbLf & _
                   "「-」が入力された座標のみ反映せずプロットをします。"
                   oneTimeMsgFlg = True
                End If
                GoTo Skip
            End If
            If lineErr(repeat) = "-" Then
                lineFlag = False
                lineErr(repeat) = 0
            End If
        Case 2
           If pointErr(repeat) = "-" Then pointErr(repeat) = 0
           If lineErr(repeat) = "-" Then lineErr(repeat) = 0
        End Select
        
        If graphicFlag = True Then '点座標でエラーがある場合のメッセージを表示する
            If Not pointErr(repeat) = "-" And (pointErr(repeat) = "" Or IsNumeric(pointErr(repeat)) = False) Then
                MsgBox "【" & classNo & " ：エラー】" & vbLf & "セルD,E,F列のセルに認識できない値、または空白の箇所が含まれています。" & vbLf & "マクロを強制終了します。"
                Call DebugPrintFile("項番" & staRow - 1 & "でエラーが発生しました。" & vbLf & _
                                    "======================【         END         】======================" & vbLf & vbLf)
                errStop = True
            End If
        End If
        If lineFlag = True Then '線座標でエラーがある場合のメッセージを表示する
            If Not lineErr(repeat) = "-" And (lineErr(repeat) = "" Or IsNumeric(lineErr(repeat)) = False) Then
                MsgBox "【" & classNo & " ：エラー】" & vbLf & "セルG,H,I列のセルに認識できない値、または空白の箇所が含まれています。" & vbLf & "マクロを強制終了します。"
                Call DebugPrintFile("項番" & staRow - 1 & "でエラーが発生しました。" & vbLf & _
                                    "======================【         END         】======================" & vbLf & vbLf)
                errStop = True
            End If
        End If
        If errStop = True Then '点または線座標でエラーがある場合は強制終了する
            Set DeleteOBJ = New Delete
            Call DeleteOBJ.Delete_OBJ
            Application.DisplayAlerts = False
            dataExtractSheet.Delete
            Application.DisplayAlerts = True
            End
        End If
    Next repeat
        
    '始点の設定(単位:mm)
     Xmm_Sta = lineErr(0)
     Ymm_Sta = lineErr(1)
     Zmm_Sta = lineErr(2)
     '終点の設定(単位:mm)
     Xmm_End = pointErr(0)
     Ymm_End = pointErr(1)
     Zmm_End = pointErr(2)
     '色の設定( RGB値 = 赤 + 緑*256 + 青*256*256 )
     graphicRGB = dataExtractSheet.Cells(staRow, 10).Interior.Color 'J2～Hcntのセル背景色RGB値
     lineRGB = dataExtractSheet.Cells(staRow, 11).Interior.Color 'K2～Hcntのセル背景色RGB値
     
    '抽出したデータの数(cnt)だけCoordinateクラスを呼び出す
    No = No + 1
    ' Debug.Print "DXT =" & Xmm_Sta, Ymm_Sta, Xmm_End, Ymm_End, Zmm_Sta, Zmm_End, lineFlag, graphicFlag, graphicRGB, lineRGB , No
     Set SetCoord = New Coordinate
     Call SetCoord.Set_Coord(Xmm_Sta, Ymm_Sta, Xmm_End, Ymm_End, Zmm_Sta, Zmm_End, _
                            lineFlag, graphicFlag, _
                            graphicRGB, lineRGB, No)
Skip:
    lineFlag = temporaryStorage 'Skipした場合lineFlagの値は引き渡された状態に戻る
    Next staRow

'終了処理
    Application.DisplayAlerts = False
    dataExtractSheet.Delete             '追加Sheetを削除
    Application.DisplayAlerts = True
    oneTimeMsgFlg = False
    
End Sub

Initialize

Option Explicit

'使い方→http://dirtysexyquery.blogspot.jp/2011/01/Clear_Vars.html
' 変数を初期化します。
' 配列と構造体は受け付けないので、注意。
' 使用例: Clear_Vars db, rs, myName, i, j, ...
Sub Clear_Vars(ParamArray args() As Variant)
    If IsMissing(args) Then Exit Sub
     
    Dim i As Integer
    Dim t As VbVarType
 
    ' For Each だとオブジェクトを初期化できないので、For ループにする
    For i = LBound(args) To UBound(args)
        t = VarType(args(i))
        If t And vbArray Then
            err.Raise 5 ' プロシージャの呼び出し、または引数が不正です。
        Else
            Select Case t
                Case vbObject
                    Set args(i) = Nothing
                Case vbString
                    args(i) = vbNullString
                Case vbBoolean, vbDate, vbByte, vbInteger, vbLong, _
                        vbDouble, vbDouble, vbCurrency, vbDecimal
                    args(i) = 0
                Case vbVariant
                    args(i) = vbEmpty
                Case Else
                    'Err.Raise 5 ' プロシージャの呼び出し、または引数が不正です。
                    On Error Resume Next
            End Select
        End If
    Next
End Sub

Log

Option Explicit

'ソースコード作成者様　→　http://tsware.jp/tips/tips_546.htm
'使う場合Mainプロシージャ起動時に myLogFlag = True を代入しないと時間が記録されない。


Public Sub DebugPrintFile(varData As Variant)

'varData As Variant

    Dim lngFileNum, No, repeat As Long
    Dim toDay, nowTime, method As Variant
    Dim strLogFile, executionTime, nowYear, nowMonth, nowDay, nowHour, nowMinute, nowSecond As String
    
    nowYear = Year(Date)
    nowMonth = Month(Date)
    nowDay = Day(Date)
    nowHour = Hour(Time)
    nowMinute = Minute(Time)
    nowSecond = Second(Time)
    
    executionTime = "起動時間 【" & nowYear & "年" & nowMonth & "月" & nowDay & "日" & _
                    nowHour & "時" & nowMinute & "分" & nowSecond & "秒】"
                    
    strLogFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & "_Log.txt"
    lngFileNum = FreeFile()
    Open strLogFile For Append As #lngFileNum
    
    'テキスト記載内容処理
    If myLogFlag = True Then  'メッセージを一回のみ表示させるIf文
        Print #lngFileNum, executionTime
        myLogFlag = False
    End If
    Print #lngFileNum, varData
    Close #lngFileNum
    
    Debug.Print varData
    
End Sub

Main

Option Explicit

'フィールド実寸の設定[単位:mm]
Public Const Xmm_ActualSize As Double = 5200
Public Const Ymm_ActualSize As Double = 8400
Public Const Zmm_ActualSize As Double = 1000
'原点[単位:mm]
Public Const Xmm_0 As Double = 2600
Public Const Ymm_0 As Double = 5600
'原点から第4象限底辺までの実寸(それぞれの原点からの最長)[単位:mm]
Public Const Xmm_Max As Double = Xmm_ActualSize - Xmm_0
Public Const Ymm_Max As Double = Ymm_ActualSize - Ymm_0
'第4象限底辺の設定[単位:ポイント]
Public Const Xpt_Max As Double = 561
Public Const Ypt_Max As Double = 825
'第2象限頂点の設定[単位:ポイント]
Public Const Xpt_Min As Double = 132
Public Const Ypt_Min As Double = 132
'Z軸最大値と最小値の設定[単位:ポイント]
Public Const Zpt_Max As Double = 82.5
Public Const Zpt_Min As Double = 0
'このエクセル上で扱うフィールドの長さ[単位:ポイント]
Public Const Xpt_Length As Double = Xpt_Max - Xpt_Min
Public Const Ypt_Length As Double = Ypt_Max - Ypt_Min
Public Const Zpt_Length As Double = Zpt_Max - Zpt_Min

'その他
Public Const objLength As Double = 5.2 '点・図の直径
Public Const zMerge As Double = 16.5   'フィールド平面図と衝立正面図の間にある長さ[単位:ポイント]
Public Const weightOfLine As Long = 3  '線の太さ
Public ScreenUpdateFlag As Boolean     'エクセルの画面更新をさせる判定
Public oneTimeMsgFlg As Boolean        'メッセージを一度だけ表示させる判定
Public temporaryStorage As Variant     '他の変数の値を一時記憶させる変数
Public myLogFlag As Boolean            'Log実行用変数

Sub Class_ALL()

'初期処理
    myLogFlag = True
    Application.ScreenUpdating = False
    
'本処理
    ScreenUpdateFlag = True
    Call Class_1
    Call Class_2
    Call Class_3
    Call Class_4
   
'終了処理
    Application.ScreenUpdating = True

End Sub

Sub Class_1()
    
    Dim Extract, ClearVars As Object
    Dim criteriaCell, classNo As String
    Dim lineFlag, graphicFlag As Boolean
    
'初期処理
'    On Error Resume Next
    myLogFlag = True
    classNo = "クラス1"
    Call DebugPrintFile("======================【    " & classNo & " Start     】======================" & vbLf)
    Sheet1.Activate
    Range("A1").Select
    Application.ScreenUpdating = False
    
'本処理
    criteriaCell = "B19:M118"            '基準となるセル
    lineFlag = Sheet3.Range("G3")        '線を引くか判定
    graphicFlag = Sheet3.Range("G4")     '図形を作るか判定
    Set Extract = New DXT
    Call Extract.Data_Extract(criteriaCell, lineFlag, graphicFlag, classNo)
    
'終了処理
    Sheet1.Activate
    Range("A1").Select
    If ScreenUpdateFlag = False Then Application.ScreenUpdating = True
    Call DebugPrintFile("======================【    " & classNo & " Finish    】======================" & vbLf & vbLf)
    
'初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(Extract, lineFlag, graphicFlag, criteriaCell, classNo)
        
End Sub

Sub Class_2()
    
    Dim Extract, ClearVars As Object
    Dim criteriaCell, classNo As String
    Dim lineFlag, graphicFlag As Boolean
    
'初期処理
'    On Error Resume Next
    myLogFlag = True
    classNo = "クラス2"
    Call DebugPrintFile("======================【    " & classNo & " Start     】======================" & vbLf)
    Sheet1.Activate
    Range("A1").Select
    Application.ScreenUpdating = False
    
'本処理
    criteriaCell = "B121:M221"           '基準となるセル
    lineFlag = Sheet3.Range("G7")        '線を引くか判定
    graphicFlag = Sheet3.Range("G8")     '図形を作るか判定
    Set Extract = New DXT
    Call Extract.Data_Extract(criteriaCell, lineFlag, graphicFlag, classNo)
    
'終了処理
    Sheet1.Activate
    Range("A1").Select
    If ScreenUpdateFlag = False Then Application.ScreenUpdating = True
    Call DebugPrintFile("======================【    " & classNo & " Finish    】======================" & vbLf & vbLf)
    
'初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(Extract, lineFlag, graphicFlag, criteriaCell, classNo)
      
End Sub

Sub Class_3()
    
    Dim Extract, ClearVars As Object
    Dim criteriaCell, classNo As String
    Dim lineFlag, graphicFlag As Boolean
    
'初期処理
'    On Error Resume Next
    myLogFlag = True
    classNo = "クラス3"
    Call DebugPrintFile("======================【    " & classNo & " Start     】======================" & vbLf)
    Sheet1.Activate
    Range("A1").Select
    Application.ScreenUpdating = False
    
'本処理
    criteriaCell = "B223:M323"           '基準となるセル
    lineFlag = Sheet3.Range("G11")       '線を引くか判定
    graphicFlag = Sheet3.Range("G12")    '図形を作るか判定
    Set Extract = New DXT
    Call Extract.Data_Extract(criteriaCell, lineFlag, graphicFlag, classNo)
    
'終了処理
    Sheet1.Activate
    Range("A1").Select
    If ScreenUpdateFlag = False Then Application.ScreenUpdating = True
    Call DebugPrintFile("======================【    " & classNo & " Finish    】======================" & vbLf & vbLf)
    
'初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(Extract, lineFlag, graphicFlag, criteriaCell, classNo)
      
End Sub

Sub Class_4()
    
    Dim Extract, ClearVars As Object
    Dim criteriaCell, classNo As String
    Dim lineFlag, graphicFlag As Boolean
    
'初期処理
'    On Error Resume Next
    myLogFlag = True
    classNo = "クラス4"
    Call DebugPrintFile("======================【    " & classNo & " Start     】======================" & vbLf)
    Sheet1.Activate
    Range("A1").Select
    Application.ScreenUpdating = False
    
'本処理
    criteriaCell = "B325:M425"           '基準となるセル
    lineFlag = Sheet3.Range("G15")       '線を引くか判定
    graphicFlag = Sheet3.Range("G16")    '図形を作るか判定
    Set Extract = New DXT
    Call Extract.Data_Extract(criteriaCell, lineFlag, graphicFlag, classNo)
    
'終了処理
    Sheet1.Activate
    Range("A1").Select
    If ScreenUpdateFlag = False Then Application.ScreenUpdating = True
    Call DebugPrintFile("======================【    " & classNo & " Finish    】======================" & vbLf & vbLf)
    
'初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(Extract, lineFlag, graphicFlag, criteriaCell, classNo)
      
End Sub

Sub Button_Del()

    Dim DeleteOBJ As Object
    
'初期処理
    Application.ScreenUpdating = False
    
'本処理
    Set DeleteOBJ = New Delete
    Call DeleteOBJ.Delete_OBJ
    
'終了処理
    Application.ScreenUpdating = True
    Set DeleteOBJ = Nothing

End Sub




'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝以下テスト用プロシージャ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

'指定したセルのポイント座標を取得する
Sub Search_Point()

    Dim test As Object
    
    Set test = New test
    Call test.Test_Search_Point
    
    Set test = Nothing
 
End Sub

'指定したセルから線を引いてみる
Sub Drow_Point()

    Dim test As Object
    
    Set test = New test
    Call test.Test_Drow_Point
 
    Set test = Nothing
    
End Sub


'右表の始点と終点の座標を線で結んでみる｡
Sub Designate_Line()

    Dim test As Object
    
    Set test = New test
    Call test.Test_Designate_Line
 
    Set test = Nothing
 
End Sub

'上図に座標 X , Y  を反映してみる｡
Sub Designate_Point_XY()

    Dim test As Object
    
    Set test = New test
    Call test.Test_Designate_Point_XY
 
    Set test = Nothing
 
End Sub

'上図に座標 Z を反映してみる｡
Sub Designate_Point_Z()

    Dim test As Object
    
    Set test = New test
    Call test.Test_Designate_Point_Z
 
    Set test = Nothing
 
End Sub

''曲線を引いてみる。
'Sub Curve()
'
'    Dim test As Object
'
'    Set test = New test
'    Call test.Drow_Curve
'
'    Set test = Nothing
'
'End Sub
'

PointConversion

Option Explicit
    
Function Pt_Conv(ansMilli, actualSize, lengthPoint, minPoint, maxMilli, maxPoint, originMilli) As Double
    
    Dim function0, function1, _
        staPoint, endPoint, originPoint, ansPoint, _
        staMilli, endMilli, minMilli As Double
    Dim ClearVars As Object
          
    function0 = actualSize / lengthPoint         '① 原点のX方向ポイント変換関数を求める
    originPoint = originMilli / function0 + minPoint    '② 原点Xm_0[mm]をXp_0[p]に変換する
    
'    Debug.Print "原点のpt関数 = " & function0
    
    function1 = maxMilli / (maxPoint - originPoint)    '③ ①で求めた原点に対応したX方向ポイント変換関数を求める
    ansPoint = ansMilli / function1 + originPoint      '④ 求める値[mm]を[p]に変換する
    
    Pt_Conv = ansPoint
    
'    Debug.Print "pt関数 = " & function1 & " 変換後 = " & Pt_Conv
    
    '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(function0, function1, staPoint, endPoint, originPoint, ansPoint, staMilli, endMilli, minMilli)
    
End Function

Sheet3(プロットデータ)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range) 'I列 120 222 324 行目に文字を挿入もしくは削除する

    Dim str As String
    Dim rows As Variant
    Dim flag As Boolean
    Dim i As Long
    
    If Target.Address() = "$B$3" Then
    If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
'    If Not (Intersect(Target, Range("B3")) Is Nothing) Then
        rows = Array(120, 222, 324)
        flag = Target
        For i = 0 To 2
        Select Case Target
            Case True
                Cells(rows(i), 13) = "Link Now"
            Case False
                Cells(rows(i), 13) = ""
        End Select
        Next i
    End If
    
End Sub

Test

Option Explicit

'指定したセルのポイント座標を取得する
Sub Test_Search_Point()

    Dim a, b, W, H, X, Y As Double
    Dim C As String
    Dim ClearVars As Object
    
    C = ActiveCell.Address

    a = ActiveSheet.Range(C).Offset(1, 1).Top
    b = ActiveSheet.Range(C).Offset(1, 1).Left

    MsgBox "X = " & a & vbLf & "Y = " & b
    
    '丸や四角の図形オブジェクトを生成
    W = objLength
    H = objLength
    X = a - (H / 2)
    Y = b - (W / 2)
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Top:=X, Left:=Y, Width:=W, Height:=H)
        .Fill.ForeColor.RGB = RGB(Int((255 + 1) * Rnd), Int((255 + 1) * Rnd), Int((255 + 1) * Rnd))
        .Select
    End With
    '枠線を太さ0.25の黒色に設定
    With Selection.ShapeRange.Line
        .Weight = 0.25
        .ForeColor.RGB = 0
    End With
    
    '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(a, b, W, H, X, Y, C)
 
End Sub

'指定したセルから線を引いてみる
Sub Test_Drow_Point()

    Dim a, b, W, H, X, Y As Double
    Dim C As String
    Dim ClearVars As Object
    
    a = Sheet2.Range("DE8")
    b = Sheet2.Range("DE11")
    
    Debug.Print a; b
    
    If (a = "" And Not a = 0) Or (b = "" And Not b = 0) Then
        MsgBox "始点を設定してください。" & vbLf & "数値は半角で入力してください。"
        Exit Sub
    End If
    
    C = ActiveCell.Address
    X = Sheet2.Range(C).Offset(1, 1).Top
    Y = Sheet2.Range(C).Offset(1, 1).Left
    
  '線の図形オブジェクトを生成
    With Sheet2.Shapes.AddLine(b, a, Y, X).Line
        .ForeColor.RGB = RGB(Int((255 + 1) * Rnd), Int((255 + 1) * Rnd), Int((255 + 1) * Rnd))
        .Weight = 2
    End With
    
    '丸や四角の図形オブジェクトを生成
    W = objLength
    H = objLength
    X = X - (W / 2) 'オブジェクトの中心に持ってくるため /2 をする
    Y = Y - (H / 2)
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Top:=X, Left:=Y, Width:=W, Height:=H)
        .Fill.ForeColor.RGB = RGB(Int((255 + 1) * Rnd), Int((255 + 1) * Rnd), Int((255 + 1) * Rnd))
        .Select
    End With
    '枠線を太さ0.25の黒色に設定
    With Selection.ShapeRange.Line
        .Weight = 0.25
        .ForeColor.RGB = 0
    End With
    
    MsgBox "X = " & X & vbLf & "Y = " & Y
 
    '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(a, b, W, H, X, Y, C)
 
End Sub

'右表の始点と終点の座標を線で結んでみる｡
Sub Test_Designate_Line()

    Dim X_Sta, Y_Sta, W, H, X_End, Y_End As Double
    Dim C As String
    Dim ClearVars As Object
    
    X_Sta = Sheet2.Range("DQ85")
    Y_Sta = Sheet2.Range("DT85")
    X_End = Sheet2.Range("DQ87")
    Y_End = Sheet2.Range("DT87")
    
    Debug.Print X_Sta, Y_Sta, X_End, Y_End
    
    If (X_Sta = Empty And Y_Sta = Empty) Or (X_End = Empty And Y_End = Empty) Then
        MsgBox "始点座標を設定してください。" & vbLf & "数値は半角で入力してください。"
        Exit Sub
'    ElseIf X_End = "" And Y_End = "" Then
'        MsgBox "終点座標を設定してください。" & vbLf & "数値は半角で入力してください。"
'        Exit Sub
    End If

    
    
  '線の図形オブジェクトを生成
    With Sheet2.Shapes.AddLine(Y_Sta, X_Sta, Y_End, X_End).Line
        .ForeColor.RGB = RGB(255, 0, 0)
        .Weight = 2
    End With
 
   '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(X_Sta, Y_Sta, W, H, X_End, Y_End, C)
 
End Sub

'上図に座標 X , Y  を反映してみる｡
Sub Test_Designate_Point_XY()

    Dim a, b, W, H, X, Y As Double
    Dim c1, c2 As String
    Dim ClearVars As Object
    
    c1 = Sheet2.Range("AX97")
    c2 = Sheet2.Range("BL97")
    MsgBox "X = " & c1 & vbLf & "Y = " & c2
    
    '丸や四角の図形オブジェクトを生成
    W = objLength
    H = objLength
    X = c1 - (W / 2)
    Y = c2 - (H / 2)
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Top:=X, Left:=Y, Width:=W, Height:=H)
        .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
        .Select
    End With
    '枠線を太さ0.25の黒色に設定
    With Selection.ShapeRange.Line
        .Weight = 0.25
        .ForeColor.RGB = 0
    End With
    
    '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(W, H, X, Y, c1, c2)
 
End Sub

'上図に座標 Z を反映してみる｡
Sub Test_Designate_Point_Z()

    Dim W, H, X, Y As Double
    Dim c1, c2, c3 As String
    Dim C, teisu, min As Variant
    Dim repeat As Long
    Dim ClearVars As Object
    
    c1 = Sheet2.Range("AX97")
    c2 = Sheet2.Range("BL97")
    c3 = Sheet2.Range("BZ97")
        
    C = Array(c1, c2)
    teisu = Array(Xpt_Max, Ypt_Max)
    min = Array(Xpt_Min, Ypt_Min)
    
    For repeat = 0 To 1
    Select Case C(repeat)
        Case C(repeat)
            If C(repeat) = teisu(repeat) Then C(repeat) = C(repeat) + c3 + zMerge
            If C(repeat) = min(repeat) Then C(repeat) = C(repeat) - c3 - zMerge
    End Select
    Next repeat
    
    If Not C(0) = c1 And Not C(1) = c2 Then
        MsgBox "平面では表現できない座標です。"
        Exit Sub
    End If
    If Not C(0) = c1 Then MsgBox "Z = " & C(0)
    If Not C(1) = c2 Then MsgBox "Z = " & C(1)
    If C(0) = c1 And C(1) = c2 Then MsgBox "X = " & c1 & vbLf & "Y = " & c2 & vbLf & "に指定したZ座標が存在します。"
    
    '丸や四角の図形オブジェクトを生成
    W = objLength
    H = objLength
    X = C(0) - (W / 2)
    Y = C(1) - (H / 2)
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Top:=X, Left:=Y, Width:=W, Height:=H)
        .Fill.ForeColor.RGB = RGB(Int((255 + 1) * Rnd), Int((255 + 1) * Rnd), Int((255 + 1) * Rnd))
        .Select
    End With
    '枠線を太さ0.25の黒色に設定
    With Selection.ShapeRange.Line
        .Weight = 0.25
        .ForeColor.RGB = 0
    End With
         
    '初期化
    Set ClearVars = New Initialize
    Call ClearVars.Clear_Vars(W, H, X, Y, c1, c2, c3, repeat)
 
End Sub

''曲線を引いてみる｡
'Sub Drow_Curve()
'
'    Dim X_Sta, Y_Sta, W, H, a, b, X_End, Y_End As Double
'    Dim C As String
'    Dim ClearVars As Object
'    Dim i As Long
'
'    X_Sta = Sheet2.Range("DY77")
'    Y_Sta = Sheet2.Range("EE77")
'    X_End = Sheet2.Range("DY79")
'    Y_End = 400
''    Y_End = Sheet2.Range("EE79")
'
'    Debug.Print X_Sta, Y_Sta, X_End, Y_End
'
'    If (X_Sta = Empty And Y_Sta = Empty) Or (X_End = Empty And Y_End = Empty) Then
'        MsgBox "始点座標を設定してください。" & vbLf & "数値は半角で入力してください。"
'        Exit Sub
'    End If
'
'
'
'    W = 0.001
'    H = 0.001
'    a = W
'    b = H
'
'
'    Debug.Print W, H
'
'    With Sheet2.Shapes.BuildFreeform(msoEditingAuto, X_Sta, Y_Sta)
'        For i = 1 To 10
'            .AddNodes msoSegmentLine, msoEditingAuto, X_Sta + X_End * a, Y_Sta + Y_End * b
'            a = a + 0.1
'            b = b + 0.1
'            Debug.Print a, b
'        Next i
'        .ConvertToShape
'    End With
'
'   '初期化
'    Set ClearVars = New Initialize
'    Call ClearVars.Clear_Vars(X_Sta, Y_Sta, W, H, X_End, Y_End, C)
'
'End Sub