Excel (VBA) |
![]() ![]() |
(Windows 11 Home : Excel 2021)
マクロを使って指定した文字を〇で囲みたいのです。
投稿日時: 23/05/19 17:00:55
投稿者: かんたV
|
---|---|
マクロを使って指定した文字を〇で囲みたいのです。
|
![]() |
投稿日時: 23/05/19 18:51:18
投稿者: WinArrow
|
---|---|
コードをインデントをつけて、整理しました。
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
|
---|---|
追加で気づいた点をメモします。
|
![]() |
投稿日時: 23/05/20 14:36:32
投稿者: かんたV
|
---|---|
ご回答ありがとうございました。試行錯誤してみます。 |
![]() |
投稿日時: 23/05/21 20:30:42
投稿者: simple
|
---|---|
作成しておいた参考コードを提示して、私の区切りとします。
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セルと思しきところが分かりませんが、 何処に記述してありますか? |