Excel Q&Aサロン(VBA)

□ 戻る　 □一般操作のサロン　 □ 使用方法　 □ 新着記事　□ 新規に質問する！　 □ トピック一覧　 □ 検索　□ 過去ログ

[ 親トピックをトピックトップへ ]

このトピックに書きこむ

Name /

E-Mail /

└>このツリーのレス記事をメールで受信しますか? YES/ NO/

Title /

URL /

Comment/ 通常モード->　図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>

解決保留迷宮入 Help! ←※回答者専用
解決したらチェック保留(コードテスト中など・・) 解決不可orレスが全く付かなくてほかのサイトに行くときなど・・

削除キー /
(半角8文字以内)　

このトピック参照回数 :

Re[13]: 指定した行にある図形の削除？？

[195959] Re[13]: 指定した行にある図形の削除？？

(2023/09/25(13:06))
□U R L/

[195958] Re[12]: 指定した行にある図形の削除？？

(2023/09/25(12:40))
□U R L/

なるほど、D列スタートの矢印は存在しないですね。

更に、短い矢印が D→I列 に何本かあって、そのすべてを削除するなら、以下のコードで。

Sub sakujo()
    Dim i As Long
    Dim LR As Long
    Dim actWsh As Worksheet
    Dim anArrow As Shape, idx As Long
    Dim dicT As Object, ky, NMs
    
    'D列からI列の間にある矢印オブジェクトを洗い出してその名称をDictionaryに登録する
    
    Set dicT = CreateObject("Scripting.Dictionary")
    
    Set actWsh = ActiveSheet
    
    For Each anArrow In actWsh.Shapes
        
        If anArrow.Type = msoLine Then
            If 4 <= anArrow.TopLeftCell.Column And anArrow.TopLeftCell.Column <= 9 Then
                ky = anArrow.TopLeftCell.Row
                dicT(ky) = dicT(ky) & "♪" & anArrow.Name
            End If
        End If
    Next
    
    LR = Cells(Rows.Count, 2).End(xlUp).Row
    
    Range(Cells(6, 2), Cells(LR, 2)).Interior.Pattern = xlNone
    
    With Range(Cells(6, 2), Cells(LR, 9))
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
        .RowHeight = 30
    End With
    
    For i = 6 To LR
        
        Select Case Cells(i, 3)
            Case "土", "日", "祝"
                Range(Cells(i, 2), Cells(i, 9)).Interior.Color = RGB(242, 220, 219)
                Range(Cells(i, 2), Cells(i, 9)).RowHeight = 13.5
                Range(Cells(i, 4), Cells(i, 9)) = ""
                Range(Cells(i, 4), Cells(i, 9)).Borders(xlDiagonalUp).LineStyle = xlLineStyleNone
                
                '                ★ここに記述したいです★
                If dicT.exists(i) Then
                    NMs = Split(dicT(i), "♪")
                    
                    For idx = 1 To UBound(NMs)
                        actWsh.Shapes(NMs(idx)).Delete
                    Next
                End If
                
            Case Else
        End Select
    Next i
    
    dicT.RemoveAll
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[195957] Re[11]: 指定した行にある図形の削除？？

(2023/09/25(12:34))
□U R L/

[195956] Re[10]: 指定した行にある図形の削除？？

(2023/09/25(12:11))
□U R L/

上と下のIF、End ID を外して、これだけで再実行してみると、イミディエイトウィンドウにどう出ますか？
                              ↓
         Debug.Print anArrow.Name, anArrow.TopLeftCell.Address, anArrow.BottomRightCell.Address

この結果を教えて頂けませんか？

[195955] Re[9]: 指定した行にある図形の削除？？

(2023/09/25(12:01))
□U R L/

[195954] Re[8]: 指定した行にある図形の削除？？

(2023/09/25(11:54))
□U R L/

＞長さは可変の矢印（図形）がD列からI列にあれば削除したいのですが、

[195953] Re[7]: 指定した行にある図形の削除？？

(2023/09/25(11:50))
□U R L/

＞上記のマクロ実行してみてもイミディエイトに何も書き込まれてません
と言うことは、D列スタートの矢印は存在しないと言うことになります（エクセル君の解釈としてはですけど）

全部書き出してチェックするしかないです。

＞        If anArrow.TopLeftCell.Column = 4 Then’チェックの為、矢印情報書き出し
＞            Debug.Print anArrow.Name, anArrow.TopLeftCell.Address, anArrow.BottomRightCell.Address
＞        End If

上と下のIF、End ID を外して、これだけで再実行してみると、イミディエイトウィンドウにどう出ますか？
                              ↓
         Debug.Print anArrow.Name, anArrow.TopLeftCell.Address, anArrow.BottomRightCell.Address



この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[195952] Re[6]: 指定した行にある図形の削除？？

(2023/09/25(11:45))
□U R L/

[195951] Re[5]: 指定した行にある図形の削除

(2023/09/25(10:51))
□U R L/

＞他に何か必要な情報などありますでしょうか？
取り敢えず、以下のマクロを実行してください。

中身は、いままでと同じですが、D列スタートの矢印の情報が
イミディエイトウィンドウに書き出されるようになっています。

その情報がどうなっているか教えてください。
こんな情報が幾つか書かれているはずです。
　　↓
Straight Connector 13       $D$12         $J$12


Sub sakujo()
    Dim i As Long
    Dim LR As Long
    Dim actWsh As Worksheet
    Dim anArrow As Shape, idx As Long
    Dim dicT As Object, ky, NMs
    
    'D列からI列への矢印オブジェクトを洗い出してその名称をDictionaryに登録する
    
    Set dicT = CreateObject("Scripting.Dictionary")
    
    Set actWsh = ActiveSheet
    
    For Each anArrow In actWsh.Shapes

        If anArrow.TopLeftCell.Column = 4 Then’チェックの為、矢印情報書き出し
            Debug.Print anArrow.Name, anArrow.TopLeftCell.Address, anArrow.BottomRightCell.Address
        End If
        
        If anArrow.Type = msoLine Then
            If anArrow.TopLeftCell.Column = 4 And anArrow.BottomRightCell.Column = 10 Then
                ky = anArrow.TopLeftCell.Address
                dicT(ky) = dicT(ky) & "♪" & anArrow.Name
            End If
        End If
    Next
    
    LR = Cells(Rows.Count, 2).End(xlUp).Row
    
    Range(Cells(6, 2), Cells(LR, 2)).Interior.Pattern = xlNone
    
    With Range(Cells(6, 2), Cells(LR, 9))
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
        .RowHeight = 30
    End With
    
    For i = 6 To LR
        
        Select Case Cells(i, 3)
            Case "土", "日", "祝"
                Range(Cells(i, 2), Cells(i, 9)).Interior.Color = RGB(242, 220, 219)
                Range(Cells(i, 2), Cells(i, 9)).RowHeight = 13.5
                Range(Cells(i, 4), Cells(i, 9)) = ""
                Range(Cells(i, 4), Cells(i, 9)).Borders(xlDiagonalUp).LineStyle = xlLineStyleNone
                
                '                ★ここに記述したいです★
                If dicT.exists(Cells(i, "D").Address) Then
                    NMs = Split(dicT(Cells(i, "D").Address), "♪")
                    
                    For idx = 1 To UBound(NMs)
                        actWsh.Shapes(NMs(idx)).Delete
                    Next
                End If
                
            Case Else
        End Select
    Next i
    
    dicT.RemoveAll
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[195950] Re[4]: 指定した行にある図形の削除

(2023/09/25(09:58))
□U R L/

[195949] Re[3]: 指定した行にある図形の削除

(2023/09/25(09:28))
□U R L/

＞If anArrow.Name Like "*Arrow*" Then
＞    If anArrow.TopLeftCell.Column = 4 And anArrow.BottomRightCell.Column = 9 Then

上記2行 を 下記2行 に変更してみてください。(こちらではその処置で削除が成功しています）

  If anArrow.Type = msoLine Then
      If anArrow.TopLeftCell.Column = 4 And anArrow.BottomRightCell.Column = 10 Then


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[195948] Re[2]: 指定した行にある図形の削除

(2023/09/25(08:49))
□U R L/

半平太さん　回答ありがとうございます

試してみたのですが罫線は消えたのですが、矢印は消えてくれませんでした
矢印は１時間目から４時間目が同じ授業の場合2時間目から３時間目のところを範囲指定して線を引く下記のマクロで引いています。

Sub 時間割用矢印()

'選択した範囲内に右向きに開いた図形の矢印を作成します
  
  Dim X1, Y1, X2, Y2
    X1 = Selection.Left                           '始点の横
    Y1 = Selection.Top + Selection.Height / 2     '始点の縦
    X2 = Selection.Left + Selection.Width         '終点の横
    Y2 = Selection.Top + Selection.Height / 2     '終点の縦
  
  With ActiveSheet.Shapes.AddLine(X1, Y1, X2, Y2).Line
    .Weight = 0.5                           '太さは１
    .ForeColor.RGB = RGB(0, 0, 0)         '色は黒
    .EndArrowheadStyle = msoArrowheadOpen '終点を開いた右向き三角矢印
  End With
    
End Sub

説明がへたくそで済みませんが再度宜しくお願いします

OS　Win8.1 　　 EXCEL Microsoft Office Standerd 2013

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[195947] Re[1]: 指定した行にある図形の削除

(2023/09/22(23:27))
□U R L/

＞長さは可変の矢印（図形）
これがどんなものか確信が持てないですが・・

Sub sakujo()
    Dim i As Long
    Dim LR As Long
    
    'D列からI列への矢印オブジェクトを洗い出してその名称をDictionaryに登録する
    Dim actWsh As Worksheet
    Dim anArrow As Shape, idx As Long
    Dim dicT As Object, ky, NMs
    
    Set dicT = CreateObject("Scripting.Dictionary")    
    Set actWsh = ActiveSheet
    
    For Each anArrow In actWsh.Shapes
        If anArrow.Name Like "*Arrow*" Then
            If anArrow.TopLeftCell.Column = 4 And anArrow.BottomRightCell.Column = 9 Then
                ky = anArrow.TopLeftCell.Address
                dicT(ky) = dicT(ky) & "♪" & anArrow.Name
            End If
        End If
    Next
        
    LR = Cells(Rows.Count, 2).End(xlUp).Row
    
    Range(Cells(6, 2), Cells(LR, 2)).Interior.Pattern = xlNone
    
    With Range(Cells(6, 2), Cells(LR, 9))
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
        .RowHeight = 30
    End With
    
    For i = 6 To LR
        
        Select Case Cells(i, 3)
            Case "土", "日", "祝"
                Range(Cells(i, 2), Cells(i, 9)).Interior.Color = RGB(242, 220, 219)
                Range(Cells(i, 2), Cells(i, 9)).RowHeight = 13.5
                Range(Cells(i, 4), Cells(i, 9)) = ""
                Range(Cells(i, 4), Cells(i, 9)).Borders(xlDiagonalUp).LineStyle = xlLineStyleNone

'                ★ここに記述したいです★
                If dicT.exists(Cells(i, "D").Address) Then
                    NMs = Split(dicT(Cells(i, "D").Address), "♪")
                    
                    For idx = 1 To UBound(NMs)
                        actWsh.Shapes(NMs(idx)).Delete
                    Next
                End If
                
            Case Else
        End Select
    Next i
    
    dicT.RemoveAll
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[195946] 指定した行にある図形の削除

(2023/09/22(14:26))
□U R L/

OS　Win8.1 　　 EXCEL Microsoft Office Standerd 2013

時間割のシートがあります
B列は日付(2013/3/22と入力、表示形式9月22日)、C列は曜日　Format(Cells(i, 2).Value, "aaa")で設定した曜日の文字が入っています。、D(１時限）E(２時限）…I(６時限）で同じ授業の最初の時限には科目、以降の時限は矢印(図形）、授業の無い時間は罫線（左下から右上）が入っています
C列が土or日or祝だった場合、長さは可変の矢印（図形）がD列からI列にあれば削除したいのですが、どのように記述したらよいのかを教えてほしいです
宜しくお願い致します


sub sakujo()

Dim i As Long
Dim LR As Integer


    LR = Cells(Rows.Count, 2).End(xlUp).Row

    Range(Cells(6, 2), Cells(LR, 2)).Interior.Pattern = xlNone

    With Range(Cells(6, 2), Cells(LR, 9))
        .Borders.LineStyle = xlContinuous
        .BorderAround Weight:=xlMedium
        .RowHeight = 30
    End With

    For i = 6 To LR
    
     Select Case Cells(i, 3)
            Case "土", "日", "祝"
            Range(Cells(i, 2), Cells(i, 9)).Interior.Color = RGB(242, 220, 219)
            Range(Cells(i, 2), Cells(i, 9)).RowHeight = 13.5
            Range(Cells(i, 4), Cells(i, 9)) = ""
            Range(Cells(i, 4), Cells(i, 9)).Borders(xlDiagonalUp) .LineStyle = xlLineStyleNone

★ここに記述したいです★
          
Case Else
        End Select
        
    Next i

End Sub

緑の太文字

茶色の太文字

赤の太文字

青の太文字

このトピック内容の全ページ数 / [0]

- Child Forum -
Edit:ゆう-Ｇ