各列にまたがっているオートシェイプ図形の線の数を列ごとにカウントすることは技術的にできますか

投稿者 : けろ     投稿日時 : 2024/08/18(Sun) 13:55:05     OS : Windows 10     EXCEL : Excel 2013

---

度々お騒がせして申し訳ございません。
横型カレンダーのガントチャートを作っております。

例えば、ですが3行目が集計行とします。
4行目から下は各機械番号が書かれており、稼働状況を示すためにC列からN列までだったり、5行目はD列のみだったり、機械によってまちまち横向きに罫線がひかれています。

3行目のC列に罫線がまたがっているのは何個、D列に罫線がまたがっているのは何個、といった形で集計というものは技術的に出せるものでしょうか。

※もちろん、少しでも罫線の列がずれるとカウントされてしまうので、そこは気を付けるものとします。

投稿者 : けろ     投稿日時 : 2024/08/18(Sun) 13:56:42

---

変な書き方をしました。

横向きに罫線がひかれていると書くと御幣がありました。
正しくはオートシェイプ図形の線が、横向きにひかれている。です。
すみません。

投稿者 : さんこう     投稿日時 : 2024/08/18(Sun) 14:08:55

---

＞3行目のC列に罫線がまたがっているのは何個、D列に罫線がまたがっているのは何個、といった形で集計というものは技術的に出せるものでしょうか。

図形（オートシェイプ）のTopLeftCellプロパティとBottomRightCellプロパティで図形のあるセル範囲がわかります。
そのセル範囲とＤ列が重複している範囲は、Intersectメソッドでわかります。

なので、できそうに思います。

投稿者 : けろ     投稿日時 : 2024/08/18(Sun) 17:29:41

---

さんこう様のアドバイスを参考に、一応こんな感じでカウント自体はできました。
当初の質問より、より具体的なセル表示になってしまってすみません。

Private Sub test_Click()

Dim shp As Object
Dim cnt As Long

For Each shp In ActiveSheet.Shapes
    If shp.Type = msoLine Then
      If shp.Line.ForeColor.RGB = RGB(180, 198, 231) Then ' 線の色
            If Not Intersect(shp.TopLeftCell, Range("C14:C45")) Is Nothing Then
            cnt = cnt + 1
            End If
       End If
     End If
Next shp

Range("C2").Value = cnt

End Sub

投稿者 : けろ     投稿日時 : 2024/08/18(Sun) 17:30:35

---

できれば今から
Dim lastcolumn_1 As Long
Set ws_1 = Worksheets("ガントチャート")
lastcolumn_1 = ws_1.Cells(12, Columns.Count).End(xlToLeft).Column '対象範囲を12行目にある日付行の最終列とするため、位置を取得

この3行を追加して、カウントを繰り返したいです。

対象は、ガントチャートというシートでC列～最終列(lastcolumn_1)までが範囲です。
各列の2行目に、14～45行目までのカウントを繰り返したいのですが、
最終的にはA列に書いてある機械A、機械B、機械C（以下続く）というキーワードごとに数字を取り出したいです。

1　　　　　　　　　　　8/1　　8/2　　8/3
2　機械A数　　　　　　　2　　　3　　　3
3　機械B数　　　　　　　2　　　2　　　1　　　　　　　
4　機械C数　　　　　　　1　　　1　　　0
5
6　機械A　　　　　　　－－－－－－－－－－
7　機械A　　　　　　　　　　－－－－－－－
8　機械B　　　　　　　－－－－－－－－－－
9　機械C　　　　　　　－－－－－－－
10 機械B　　　　　　　－－－－－－－
11 機械A　　　　　　　－－－－－－－－－－
・
・
・
45行目


■[返信 3] けろさん（2024-08-18 17:29:41）の記事
＞ さんこう様のアドバイスを参考に、一応こんな感じでカウント自体はできました。
＞ 当初の質問より、より具体的なセル表示になってしまってすみません。
＞
＞ Private Sub test_Click()
＞
＞ Dim shp As Object
＞ Dim cnt As Long
＞
＞ For Each shp In ActiveSheet.Shapes
＞ If shp.Type = msoLine Then
＞ If shp.Line.ForeColor.RGB = RGB(180, 198, 231) Then ' 線の色
＞ If Not Intersect(shp.TopLeftCell, Range("C14:C45")) Is Nothing Then
＞ cnt = cnt + 1
＞ End If
＞ End If
＞ End If
＞ Next shp
＞
＞ Range("C2").Value = cnt
＞
＞ End Sub

投稿者 : さんこう     投稿日時 : 2024/08/18(Sun) 18:11:04

---

＞各列の2行目に、14～45行目までのカウントを繰り返したいのですが

各図形があるセル範囲が、各列と重複しているかを、図形がある行のA列に記載されているキーワードごとにカウントすればいいでしょう。


図形（オートシェイプ）のTopLeftCellプロパティとBottomRightCellプロパティで図形のあるセル範囲がわかります。

そのセル範囲と特定の列が重複している範囲は、Intersectメソッドでわかります。

また、１つの図形のあるセル範囲は１行に収まっているでしょうから、その行番号は、TopLeftCellプロパティで得られたRangeオブジェクトのRowプロパティでわかります。それを使えば、図形に対するA列のキーワードもわかります。

投稿者 : higeru     投稿日時 : 2024/08/18(Sun) 20:37:48

---

　線なんか引かずに 1 でも○でも書いたらよいと思うのですがねぇ。

> 機械A、機械B、機械C（以下続く）

ということですが、結果を書き出す範囲が3行しかないので、とりあえず3種類としています。

> 14～45行目までのカウントを繰り返したい

行について繰り返すのではなく、TopLeftCell がこの範囲内にある（特定の色の）直線について繰り返しています。

Sub sample()
    Dim ws_1 As Worksheet: Set ws_1 = Worksheets("ガントチャート")
    Dim lastcolumn_1 As Long
    lastcolumn_1 = ws_1.Cells(12, Columns.Count).End(xlToLeft).Column
    ReDim mm(1 To 3, 1 To lastcolumn_1 - 2) As Long
    Dim dic As New Dictionary
    Dim shp As Shape
    For Each shp In ws_1.Shapes
        If shp.Type <> msoLine Then GoTo Continue
        If shp.Line.ForeColor.RGB <> RGB(180, 198, 231) Then GoTo Continue
        If Intersect(Range(Range("C6"), Cells(45, lastcolumn_1)), shp.TopLeftCell) Is Nothing Then GoTo Continue
        Dim i As Long
        Dim mname As String: mname = Cells(shp.TopLeftCell.Row, 1).Value
        If Not dic.Exists(mname) Then
            i = i + 1
            dic(mname) = i
        End If
        Dim j As Long
        For j = shp.TopLeftCell.Column - 2 To shp.BottomRightCell.Column - 2
            mm(dic(mname), j) = mm(dic(mname), j) + 1
        Next
Continue:
    Next
    For i = 2 To 4
        For j = 1 To lastcolumn_1 - 2
            Cells(i, j + 2) = mm(dic(Cells(i, 1).Value), j)
        Next
    Next
End Sub

投稿者 : けろ     投稿日時 : 2024/08/19(Mon) 10:09:23

---

higeru様
ありがとうございます。

Dim dic As New Dictionaryのところでコンパイルエラーが出てしまいました。
ユーザ定義型は定義されていません。となりました。
こちらのエクセルのバージョン（2013）のせいでしょうか。


○等文字を入れれば早いのですが移動することがあり、セル色がついた土日にまたがっていると、
そこをコピーしたりして移動するとセルの色や線がぽっかりあいてしまい、そこを埋めるためにひと作業発生してしまい断念しました。



■[返信 6] higeruさん（2024-08-18 20:37:48）の記事
＞ 　線なんか引かずに 1 でも○でも書いたらよいと思うのですがねぇ。
＞
＞ > 機械A、機械B、機械C（以下続く）
＞
＞ ということですが、結果を書き出す範囲が3行しかないので、とりあえず3種類としています。
＞
＞ > 14～45行目までのカウントを繰り返したい
＞
＞ 行について繰り返すのではなく、TopLeftCell がこの範囲内にある（特定の色の）直線について繰り返しています。
＞
＞ Sub sample()
＞ Dim ws_1 As Worksheet: Set ws_1 = Worksheets("ガントチャート")
＞ Dim lastcolumn_1 As Long
＞ lastcolumn_1 = ws_1.Cells(12, Columns.Count).End(xlToLeft).Column
＞ ReDim mm(1 To 3, 1 To lastcolumn_1 - 2) As Long
＞ Dim dic As New Dictionary
＞ Dim shp As Shape
＞ For Each shp In ws_1.Shapes
＞ If shp.Type <> msoLine Then GoTo Continue
＞ If shp.Line.ForeColor.RGB <> RGB(180, 198, 231) Then GoTo Continue
＞ If Intersect(Range(Range("C6"), Cells(45, lastcolumn_1)), shp.TopLeftCell) Is Nothing Then GoTo Continue
＞ Dim i As Long
＞ Dim mname As String: mname = Cells(shp.TopLeftCell.Row, 1).Value
＞ If Not dic.Exists(mname) Then
＞ i = i + 1
＞ dic(mname) = i
＞ End If
＞ Dim j As Long
＞ For j = shp.TopLeftCell.Column - 2 To shp.BottomRightCell.Column - 2
＞ mm(dic(mname), j) = mm(dic(mname), j) + 1
＞ Next
＞ Continue:
＞ Next
＞ For i = 2 To 4
＞ For j = 1 To lastcolumn_1 - 2
＞ Cells(i, j + 2) = mm(dic(Cells(i, 1).Value), j)
＞ Next
＞ Next
＞ End Sub

投稿者 : higeru     投稿日時 : 2024/08/19(Mon) 11:53:21

---

ああ、失礼。参照設定バージョンのままアップしてしまいました。以下を修正してください。

Dim dic As New Dictionary
　↓
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

投稿者 : けろ     投稿日時 : 2024/08/19(Mon) 15:12:27

---

少々苦戦中です。

こちらが作ったガントチャートがよろしくなくて、
Cells(i, j) = mm(dic(Cells(i, 1).Value), j)
mm(dic(mname), j) = mm(dic(mname), j) + 1
上記２つでインデックス範囲エラーが起きてしまいました。
現状、下のようになっています。後出しにした私が悪いですすみません。

機械A～Eは確定しています。1行目～11行目は確定です。行が増える事はありません。
14行目～45行目のA列は人員によって変わります。
機械それぞれかなり多い時もありますし、少ない時もあります。
できれば、A列判定かつ、線の色でもカウントを分けたいです。
質問が多くてすみません。

　　　A　　　　　B　　　　　C　　　　　D　　　　　E
1　ガントチャート
2　機械A　　　　青線　　　　2　　　　　2　　　　　1
3　機械A　　　　赤線　　　　0　　　　　1　　　　　1
4　機械B　　　　青線　　　　1　　　　　2　　　　　2
5　機械B　　　　赤線　　　　0　　　　　0　　　　　0
6　機械C　　　　青線　　　　1　　　　　1　　　　　0
7　機械C　　　　赤線　　　　0　　　　　0　　　　　0
8　機械D　　　　青線　　　　1　　　　　1　　　　　1
9　機械D　　　　赤線　　　　0　　　　　0　　　　　0
10 機械E　　　　青線　　　　0　　　　　0　　　　　0
11 機械E　　　　赤線　　　　1　　　　　1　　　　　1
12 日付　　　　　　　　　　8/1　　　　8/2　　　　8/3
13 曜日　　　　　　　　　　木　　　　　金　　　　土
14 機械A　　　　田中　　　　－－－－－－－－－－－－－　←稼働しているので青線
15 機械A　　　　佐藤　　　　－－－－－－－－
16 機械A　　　　不足　　　　　　　　－－－－－－－－－　←人員不足の為赤線
17
18 機械B　　　　鈴木　　　　　　　　－－－－－－－－－
19 機械B　　　　加藤　　　　－－－－－－－－－－－－－
20
21 機械C　　　　伊藤　　　　－－－－－－－－－
22
23 機械D　　　　木村　　　　－－－－－－－－－－－－－
24
25 機械E　　　　不足　　　　－－－－－－－－－－－－－
・
・
・
・
45

投稿者 : ピロリ     投稿日時 : 2024/08/19(Mon) 18:03:33

---

後出しと言うよりも、どんどん仕様を膨らましているような気もしますけど･･･
サンプルコードを載せておきます。　参考になれば。
考え方は higeruさんと一緒ですが、Dictionary の使用は もう少しお勉強（理解）してからが良いかと。

Sub Test()
    Dim ws As Worksheet, last_col As Long, machine As Variant
    Set ws = Worksheets("ガントチャート")
    last_col = ws.Cells(12, Columns.Count).End(xlToLeft).Column         '最終列(最終日付の列)
    machine = ws.Range("A2:B11").Value                                  '機械名と線色
    Range(ws.Cells(2, "C"), ws.Cells(11, last_col)).Value = 0           '稼働台数を初期化
    
    Dim i As Long, j As Long, check_r As Range, shp As Shape, shp_r As Range
    For i = 1 To 10
        If machine(i, 2) = "青線" Then machine(i, 2) = RGB(0, 0, 255)   '｢青線｣を RBG値に変換
        If machine(i, 2) = "赤線" Then machine(i, 2) = RGB(255, 0, 0)   '｢赤線｣を RBG値に変換
    Next i
    For i = 3 To last_col                                               '日付分のループ
        Set check_r = Range(ws.Cells(14, i), ws.Cells(45, i))           'その日のセル範囲
        For Each shp In ws.Shapes                                       '図形分のループ
            If shp.Type = msoLine Then                                  '図形が線(Line)なら、
                Set shp_r = Range(shp.TopLeftCell, shp.BottomRightCell) '線が跨るセルの範囲
                If Not Intersect(shp_r, check_r) Is Nothing Then        '線がその日を跨いでたら、
                    For j = 1 To 10
                        If ws.Cells(shp.TopLeftCell.Row, "A") = machine(j, 1) And _
                           shp.Line.ForeColor.RGB = machine(j, 2) Then  '機械名と線色の一致で、
                            ws.Cells(j + 1, i) = ws.Cells(j + 1, i) + 1 '稼働台数を加算
                        End If
                    Next j
                End If
            End If
        Next shp
    Next i
End Sub

投稿者 : けろ     投稿日時 : 2024/08/19(Mon) 19:30:17

---

ピロリ様

ありがとうございました。こちら都合でどんどん膨らんでしまったのにも関わらず、説明書きまでつけていただき大変恐縮です。
やりたかった事ができました。本当に感謝しています。
文言を検索しながら勉強したいと思います。