Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 11 Home : Excel 2021)
マクロを使って指定した文字を〇で囲みたいのです。
投稿日時: 23/05/19 17:00:55
投稿者: かんたV

マクロを使って指定した文字を〇で囲みたいのです。
サイトでサンプルを探してみたのですがいまいちわかりにくかったのでサンプルを添付しますので添削と修正をお願いできればと思います。
 
サンプル
Sub 〇で囲む()
    Dim Ash As Worksheet
    Dim Bsh As Worksheet
    Set Ash = ThisWorkbook.Worksheets("設定")
    Set Bsh = ThisWorkbook.Worksheets("図形挿入")
    Dim zukeiA As Shape
    For Each zukeiA In Bsh.Shapes
    On Error Resume Next
    If zukeiA.TopLeftCell.Address >= Bsh.Cells(1, 1).Address Then
    zukeiA.Delete
    End If
    If Err <> 0 Then
    Err.Clear
    End If
    Next
    Dim ARange As Range
    Dim keyWord As String
    Dim zukeiH As Range
    gyoa = Ash.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 4 To gyoa
    keyWord = Ash.Cells(i, 2)
    For j = 1 To 10
    For k = 1 To 10
    Set ARange = Range(Cells(j, k), Cells(j, k))
    Set zukeiH = ARange.Find(keyWord, LookAt:=xlWhole)
    If zukeiH = keyWord And Len(keyWord) = 1 Then
        With Bsh.Shapes.AddShape(msoShapeOval, zukeiH.Left, zukeiH.Top, 15, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
        End With
    ElseIf zukeiH = keyWord And Len(keyWord) = 2 Then
        With Bsh.Shapes.AddShape(msoShapeOval, zukeiH.Left, zukeiH.Top, 30, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
        End With
    ElseIf zukeiH = keyWord And Len(keyWord) = 3 Then
        With Bsh.Shapes.AddShape(msoShapeOval, zukeiH.Left, zukeiH.Top, 40, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
        End With
    ElseIf zukeiH = keyWord And Len(keyWord) = 4 Then
        With Bsh.Shapes.AddShape(msoShapeOval, zukeiH.Left, zukeiH.Top, 50, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
        End With
    ElseIf zukeiH = keyWord And Len(keyWord) = 5 Then
        With Bsh.Shapes.AddShape(msoShapeOval, zukeiH.Left, zukeiH.Top, 60, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
        End With
    Else
    End If
    Next
    Next
    Next
End Sub
 
 
 
 
となっています。設定ワークシートの参照セルはC25です。そこに入力する文字を図形挿入のワークシートの文字を〇印で囲いたいです。ご教授宜しくお願い致します。

回答
投稿日時: 23/05/19 18:51:18
投稿者: WinArrow

コードをインデントをつけて、整理しました。
インデントをキチンと付けることで可読性がよくがよくなります。
何カ所か問題があります。
 
(1)エラートラップは、必要でしょうか?
 必要であるとしたら、エラートラップは必要な場所で、解除しましょう。 
 解除せずに実行すると、本当のエラーを見逃すことになります。
(2)変数の未定義がいくつかあります。コンパイルエラー
少なウとも、コードを掲示する際は、コンパイルエラーが潰しておいてください。
 
コード上の問題個所を「★で示しておきます。
 
図形作成処理をサブルーチンにしました。
 

Sub 〇で囲む()
    Dim Ash As Worksheet
    Dim Bsh As Worksheet
    Set Ash = ThisWorkbook.Worksheets("設定")
    Set Bsh = ThisWorkbook.Worksheets("図形挿入")
    
    Dim zukeiA As Shape
    For Each zukeiA In Bsh.Shapes
        On Error Resume Next
        If zukeiA.TopLeftCell.Address >= Bsh.Cells(1, 1).Address Then
            zukeiA.Delete
        End If
        If Err <> 0 Then
            Err.Clear
        End If
    Next
    Dim ARange As Range
    Dim keyWord As String
    Dim zukeiH As Range
    Dim gyoA As Long, i As Long, j As Long, k As Long '★
    gyoA = Ash.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 4 To gyoA
        keyWord = Ash.Cells(i, 2)
        For j = 1 To 10
            For k = 1 To 10
                Set ARange = Range(Cells(j, k), Cells(j, k)) '★シートで修飾しましょう。
                Set zukeiH = ARange.Find(keyWord, LookAt:=xlWhole)
                If zukeiH.Value = keyWord Then
                    Select Case Len(keyWord)
                        Case 1
                            Call ZUKEI_SAKUSEI(wWIDTH:=15, ZUKEI:=zukeiH, Bsh:=Bsh)
                        Case 2
                            Call ZUKEI_SAKUSEI(wWIDTH:=30, ZUKEI:=zukeiH, Bsh:=Bsh)
                        Case 3
                            Call ZUKEI_SAKUSEI(wWIDTH:=40, ZUKEI:=zukeiH, Bsh:=Bsh)
                        Case 4
                            Call ZUKEI_SAKUSEI(wWIDTH:=50, ZUKEI:=zukeiH, Bsh:=Bsh)
                        Case 5
                            Call ZUKEI_SAKUSEI(wWIDTH:=60, ZUKEI:=zukeiH, Bsh:=Bsh)
                    End Select
                End If
            Next
        Next
    Next
End Sub

Private Sub ZUKEI_SAKUSEI(ByVal wWIDTH As Single, ByVal ZUKEI As Range, Bsh As Worksheet)
    With Bsh.Shapes.AddShape(msoShapeOval, ZUKEI.Left, ZUKEI.Top, wWIDTH, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlock
     End With
End Sub

回答
投稿日時: 23/05/20 07:33:43
投稿者: simple

追加で気づいた点をメモします。
 
1. 検索ワードはC25セルにある一つの単語だけですか?
   それなら、AシートのB列の繰り返しは不要ですね。
   その修正はそちらで実行してください。
 
2.検索範囲は、BシートのA1から始まる10行、10列で変わりないのですか?
   Set ARange = Range(Cells(j, k), Cells(j, k))
   は、単にSet ARange = Cells(j, k)でしょう。
 
   Set zukeiH = ARange.Find(keyWord, LookAt:=xlWhole)
   と単一のセルに対してFind(しかも完全一致)する意味が不明です。
   単に セルの値を = keyWord という形で判定すれば十分では?
     
   10行、10列のセル範囲を対象に Findメソッドを実行して、
   (FindNextを併用して)検索を繰り返す方法もあります。
   より広い範囲ですと、速度面ではFindの使用が有利ですが、やや複雑なコードになります。
   コード例は、Findメソッドのヘルプにありますから、それが参考になります。
 
こうした話は、ご自分でトライしてみたほうがよいと思います。
それがよい経験になるからです。
そのうえで詰まったところを質問されたらいかがですか?

投稿日時: 23/05/20 14:36:32
投稿者: かんたV

ご回答ありがとうございました。試行錯誤してみます。

回答
投稿日時: 23/05/21 20:30:42
投稿者: simple

作成しておいた参考コードを提示して、私の区切りとします。
 
Rem スクラッチで書くなら、こうですか。

Sub 〇で囲む()
    Dim wsA     As Worksheet
    Dim wsB     As Worksheet
    Set wsA = ThisWorkbook.Worksheets("設定")
    Set wsB = ThisWorkbook.Worksheets("図形挿入")

    'AutoShapeをすべて消去
    Dim sp      As Shape
    For Each sp In wsB.Shapes
        If sp.Type = msoAutoShape Then sp.Delete
    Next

    'keywordに一致するセルを探して、丸で囲む
    Dim rng     As Range
    Dim keyWord As String
    Dim myWidth As Double

    ' 検索対象範囲
    Set rng = wsB.Range("A1").Resize(10, 10)
    ' 検索語
    keyWord = wsA.Range("C25")
    If keyWord = "" Then
        MsgBox "キーワードなし。終了"
        Exit Sub
    Else
        myWidth = getWidth(keyWord)
    End If
    
    ' 範囲内をkeywordと一致するか調べ、ヒットしたら丸で囲む
    Dim e       As Range
    For Each e In rng
        If e.Value = keyWord Then
            Call AddOval(e, myWidth)
        End If
    Next

    '   '範囲が広く、速度を重視するならこうも書けます
    '    Dim c As Range
    '    Dim firstAddress As String
    '    Set c = rng.Find(keyWord, LookAt:=xlWhole)
    '    If Not c Is Nothing Then
    '        firstAddress = c.Address
    '        Do
    '            Call AddOval(c, myWidth)
    '            Set c = rng.FindNext(c)
    '        Loop While Not c Is Nothing And c.Address <> firstAddress
    '    End If
End Sub

Function getWidth(s As String) As Double
    Select Case Len(s)
        Case 1: getWidth = 15
        Case 2: getWidth = 30
        Case 3: getWidth = 40
        Case 4: getWidth = 50
        Case Else: getWidth = 60
    End Select
End Function

Sub AddOval(c As Range, myWidth As Double)
    With c.Parent.Shapes.AddShape(msoShapeOval, c.Left, c.Top, myWidth, 15)
        .Fill.Visible = msoFalse
        .Line.Weight = 1
        .Line.ForeColor.RGB = vbBlack
    End With
End Sub

回答
投稿日時: 23/05/22 09:06:30
投稿者: WinArrow

引用:
設定ワークシートの参照セルはC25です。

 
コードの中には、C25セルと思しきところが分かりませんが、
何処に記述してありますか?

トピックに返信