{"id":3429,"date":"2013-07-26T16:06:06","date_gmt":"2013-07-26T07:06:06","guid":{"rendered":"http:\/\/fujiitoshiki.com\/improvesociety\/?p=3429"},"modified":"2014-07-31T13:46:52","modified_gmt":"2014-07-31T04:46:52","slug":"post-3429","status":"publish","type":"post","link":"https:\/\/www.fujiitoshiki.com\/improvesociety\/?p=3429","title":{"rendered":"EXCEL\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u306b\u304a\u3044\u3066\u6570\u5f0f\u306e\u53c2\u7167\u5143\u306e\u6700\u521d\u306e\u30bb\u30eb\u304a\u3088\u3073\u53c2\u7167\u5148\u306e\u6700\u5f8c\u306e\u30bb\u30eb\u3092\u53d6\u5f97\u3059\u308b"},"content":{"rendered":"

\u3000\u6570\u5f0f\u306e\u53c2\u7167\u5143\u30bb\u30eb\u304c\u591a\u6570\u5b58\u5728\u3059\u308b\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u3092\u89e3\u6790\u3057\u306a\u3051\u308c\u3070\u306a\u3089\u306a\u3044\u5834\u5408\u304c\u3042\u308a\u307e\u3059\uff0e\u5927\u62b5\u306e\u5834\u5408\uff0c\u4e00\u3064\u306e\u30bb\u30eb\u304c\u4ed6\u306e\u30bb\u30eb\u306e\u53c2\u7167\u5143\u3068\u306a\u3063\u3066\u3044\u3066\uff0c\u304b\u3064\u5225\u306e\u30bb\u30eb\u306e\u53c2\u7167\u5148\u306b\u306a\u3063\u3066\u3044\u308b\u3053\u3068\u304c\u6b86\u3069\u3067\u3059\uff0e\u53c2\u7167\u5143\u306e\u66f4\u306b\u53c2\u7167\u5143\u3092\u8fbf\u3063\u3066\u884c\u304f\u3068\uff0c\u305d\u308c\u4ee5\u4e0a\u306f\u53c2\u7167\u5143\u306e\u306a\u3044\u6700\u521d\u306e\u30bb\u30eb\u306b\u884c\u304d\u7740\u304d\u307e\u3059\uff0e\u4eca\u56de\u306e\u8a18\u4e8b\u3067\u306f\u305d\u306e\u6700\u521d\u306e\u53c2\u7167\u5143\u306e\u30bb\u30eb\u3092\u63a2\u3059\u30b3\u30fc\u30c9\u3092\u7d39\u4ecb\u3057\u307e\u3059\uff0e<\/p>\n

\u30002 \u3064\u306e\u96c6\u5408\u304c\u7b49\u3057\u3044\u304b\u3092\u78ba\u8a8d\u3059\u308b\u65b9\u6cd5\u3092\u7528\u3044\u307e\u3059\uff0e\u3042\u308b\u96c6\u5408 A \u3068 B \u3068\u304c\u7b49\u3057\u3044\u3068\u8a3c\u660e\u3059\u308b\u306b\u306f\uff0c\u96c6\u5408 A \u3068\u96c6\u5408 B \u306e\u548c\u3068\u7a4d\u3068\u3092\u3068\u308a\u307e\u3059\uff0e\u548c\u96c6\u5408 A ∪ B \u3068\u7a4d\u96c6\u5408 A ∩ B \u3068\u306e\u8981\u7d20\u6570\u304c\u7b49\u3057\u3051\u308c\u3070\u96c6\u5408 A \u3068\u96c6\u5408 B \u306f\u7b49\u3057\u3044\u3068\u8a00\u3048\u307e\u3059\uff0e<\/p>\n

\u3000\u6bd4\u8f03\u3059\u308b\u5bfe\u8c61\u306f Range \u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e DirectPrecedents \u30d7\u30ed\u30d1\u30c6\u30a3\u3068 Precedents \u30d7\u30ed\u30d1\u30c6\u30a3\u3067\u3059\uff0e\u305d\u308c\u305e\u308c\u30bb\u30eb\u306e\u76f4\u63a5\u53c2\u7167\u5143\u3068\u53c2\u7167\u5143\u5168\u3066\u3092\u53d6\u5f97\u3059\u308b\u30d7\u30ed\u30d1\u30c6\u30a3\u3067\u3042\u308a\uff0c\u305d\u308c\u3089\u304c\u4e00\u81f4\u3059\u308c\u3070\u53c2\u7167\u5143\u304c\u6700\u521d\u306e\u30bb\u30eb\u3068\u306a\u308a\u307e\u3059\uff0e\u524d\u63d0\u6761\u4ef6\u3068\u3057\u3066\u4ed6\u306e\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u3078\u306e\u53c2\u7167\u304c\u306a\u304f\uff0c\u5faa\u74b0\u53c2\u7167\u3092\u4f7f\u7528\u3057\u3066\u3044\u306a\u3044\u3082\u306e\u3068\u3057\u307e\u3059\uff0e<\/p>\n

\u3000\u30bb\u30eb\u306e\u53c2\u7167\u5143\u3068\u53c2\u7167\u5148\u3092\u5168\u3066\u7e4b\u3050\u3068\u6728\u69cb\u9020\u306b\u306a\u308a\u307e\u3059\uff0e\u6700\u521d\u306e\u53c2\u7167\u5143\uff0c\u6700\u5f8c\u306e\u53c2\u7167\u5148\uff0c\u3069\u3061\u3089\u306e\u30eb\u30fc\u30c8\u304b\u3089\u8fbf\u3063\u3066\u3082\u6728\u69cb\u9020\u304c\u3067\u304d\u307e\u3059\uff0e\u69cb\u6210\u5c55\u958b\u3067\u518d\u5e30\u7684\u306b\u30ce\u30fc\u30c9\u3092\u5c55\u958b\u3057\uff0c\u4eca\u56de\u4f5c\u6210\u3057\u305f\u95a2\u6570\u3067\u30ea\u30fc\u30d5\u304b\u5426\u304b\u3092\u5224\u5b9a\u3057\u307e\u3059\uff0e\u30d5\u30a9\u30eb\u30c0\u3084\u90e8\u54c1\u8868\u306e\u5c55\u958b\u306a\u3069\u3067\u4e00\u822c\u7684\u306b\u7528\u3044\u3089\u308c\u308b\u624b\u6cd5\u3067\u3059\uff0e<\/p>\n

\r\nOption Explicit\r\nSub FirstPrecedents()\r\n    Dim Sh1 As Worksheet\r\n    Dim Sh2 As Worksheet\r\n    Dim i   As Long\r\n    Dim tmp As Range\r\n    Set Sh1 = ActiveSheet\r\n    Set Sh2 = Worksheets.Add\r\n    Sh2.Name = \"TraceFormula\"\r\n    i = 1\r\n    For Each tmp In Sh1.UsedRange\r\n        On Error Resume Next\r\n        If Left(tmp.Formula, 1) = \"=\" Then\r\n            If CheckEqualRange(tmp.DirectPrecedents, tmp.Precedents) Then\r\n                With Sh2\r\n                    .Cells(i, 1) = tmp.Address\r\n                    .Cells(i, 2) = \"'\" & tmp.Formula\r\n                    .Cells(i, 3) = tmp.DirectPrecedents.Address\r\n                    .Cells(i, 4) = tmp.Precedents.Address\r\n                    .Cells(i, 5) = tmp.DirectPrecedents.Cells.Count\r\n                    .Cells(i, 6) = tmp.Precedents.Cells.Count\r\n                    .Cells(i, 7) = CheckEqualRange(tmp.DirectPrecedents, tmp.Precedents)\r\n                End With\r\n                tmp.DirectPrecedents.Interior.Color = RGB(242, 220, 219)\r\n                i = i + 1\r\n            End If\r\n        End If\r\n        On Error GoTo 0\r\n    Next tmp\r\nEnd Sub\r\n\r\nFunction CheckEqualRange(ByRef Rng1 As Range, ByRef Rng2 As Range) As Boolean\r\n    Dim UnionRange      As Range\r\n    Dim IntersectRange  As Range\r\n    Dim tmp             As Range\r\n    CheckEqualRange = False\r\n    Set UnionRange = Application.Union(Rng1, Rng2)\r\n    Set IntersectRange = Application.Intersect(Rng1, Rng2)\r\n    If UnionRange.Cells.Count = IntersectRange.Cells.Count Then\r\n        CheckEqualRange = True\r\n    End If\r\nEnd Function\r\n<\/pre>\n
\u3000\u3082\u3046\u4e00\u3064\u306e\u65b9\u6cd5\u3068\u3057\u3066\uff0cRange \u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e DirectDependents \u30d7\u30ed\u30d1\u30c6\u30a3\u3068 DirectPrecedents \u30d7\u30ed\u30d1\u30c6\u30a3\u3092\u6bd4\u8f03\u3059\u308b\u65b9\u6cd5\u3082\u3042\u308a\u307e\u3059\uff0eDirectPrecedents \u30d7\u30ed\u30d1\u30c6\u30a3\u304c\u5b58\u5728\u305b\u305a\uff0cDirectDependents \u30d7\u30ed\u30d1\u30c6\u30a3\u304c\u5b58\u5728\u3059\u308c\u3070\u305d\u308c\u306f\u30eb\u30fc\u30c8\u3067\u3042\u308b\u3068\u3044\u3046\u3053\u3068\u3067\u3059\uff0e<\/p>\n
\r\nOption Explicit\r\nSub FirstPrecedents2()\r\n    Dim Sh1 As Worksheet\r\n    Dim Sh2 As Worksheet\r\n    Dim i   As Long\r\n    Dim tmp As Range\r\n    Set Sh1 = ActiveSheet\r\n    Set Sh2 = Worksheets.Add\r\n    Sh2.Name = \"Root\"\r\n    i = 1\r\n    For Each tmp In Sh1.UsedRange\r\n        On Error Resume Next\r\n        If Left(tmp.Formula, 1) = \"=\" Then\r\n            If tmp.DirectPrecedents Is Nothing And _\r\n               Not tmp.DirectDependents Is Nothing Then\r\n                Sh2.Cells(i, 1) = tmp.Address\r\n                i = i + 1\r\n            End If\r\n        End If\r\n        On Error GoTo 0\r\n    Next tmp\r\nEnd Sub\r\n<\/pre>\n
\u3000\u3064\u3044\u3067\u306b\u53c2\u7167\u5148\u306e\u6700\u5f8c\u306e\u30bb\u30eb\u3092\u53d6\u5f97\u3059\u308b\u30b3\u30fc\u30c9\u3082\u7d39\u4ecb\u3057\u3066\u304a\u304d\u307e\u3059\uff0e\u6761\u4ef6\u5f0f\u306e\u771f\u7406\u5024\u3092\u9006\u8ee2\u3055\u305b\u308b\u3060\u3051\u3067\u3059\uff0e<\/p>\n
\r\nOption Explicit\r\nSub LastDependents()\r\n    Dim Sh1 As Worksheet\r\n    Dim Sh2 As Worksheet\r\n    Dim i   As Long\r\n    Dim tmp As Range\r\n    Set Sh1 = ActiveSheet\r\n    Set Sh2 = Worksheets.Add\r\n    Sh2.Name = \"Leaf\"\r\n    i = 1\r\n    For Each tmp In Sh1.UsedRange\r\n        On Error Resume Next\r\n        If Left(tmp.Formula, 1) = \"=\" Then\r\n            If tmp.DirectDependents Is Nothing And _\r\n                Not tmp.DirectPrecedents Is Nothing Then\r\n                tmp.Interior.Color = RGB(220, 230, 241)\r\n                Sh2.Cells(i, 1) = tmp.Address\r\n                i = i + 1\r\n            End If\r\n        End If\r\n        On Error GoTo 0\r\n    Next tmp\r\nEnd Sub\r\n<\/pre>\n