k窓 ExcelVBA技全般

ExcelVBA技全般 E13M013

E13M013 (Excel2000～2013)
記録したマクロの修正ヒント

ある動作をVBAで記述する場合にマクロの記録を用いると簡単にコードのスケルトンを得る事が出来ます。
([開発]タブ-[コード]グループ-[新しいマクロの記録])
ただ、そのままでは色々不都合があって、不要箇所の削除やコードの整理が必要です。操作の手順を記録するのでActivateやSelectプロパティが多用されたコードになり、セルやシートの移動を伴いあまりスマートではありません。
Activate、Select プロパティを使わずカーソル位置が変化しないコードに変更するためのヒントを示します。
また、オブジェクトの階層・メンバを良く理解しておく必要のある修正例を示します。

'例1: Sheet1 B2 のデータをSheet2 B2 へコピー&貼り付け(すべて)する
'マクロの記録結果
  Range("B2").Select
  Selection.Copy
  Sheets("Sheet2").Select
  Range("B2").Select
  ActiveSheet.Paste
  Sheets("Sheet1").Select
  Application.CutCopyMode = False

'修正したコード
  Range("B2").Copy Worksheets("Sheet2").Range("B2")

'例2: Sheet1 B2 のデータをSheet2 B2 へ形式を選択して貼り付け(値)する
'マクロの記録結果
  Range("B2").Select
  Selection.Copy
  Sheets("Sheet2").Select
  Range("B2").Select
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Sheets("Sheet1").Select
  Application.CutCopyMode = False

'修正したコード
  Worksheets("Sheet2").Range("B2").Value = Range("B2").Value

'例3: Sheet1 B2 のデータをSheet2 B2 へ形式を選択して貼り付け(書式)する
'マクロの記録結果
  Range("B2").Select
  Selection.Copy
  Sheets("Sheet2").Select
  Range("B2").Select
  Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Sheets("Sheet1").Select
  Application.CutCopyMode = False

'修正したコード
  ActiveSheet.Range("B2").Copy
  Worksheets("Sheet2").Range("B2").PasteSpecial Paste:=xlFormats
  Application.CutCopyMode = False

'例4: 任意の名前のシートを作成する
'マクロの記録結果
  Sheets.Add
  Sheets("Sheet3").Select
  Sheets("Sheet3").Name = "sss"

'修正したコード
  Sheets.Add.Name = "sss"

'例5: 選択したセルに罫線(格子枠)を引く
'[書式]-[セル]-[罫線]で格子枠を点線、赤色に設定
'マクロの記録結果
  Range("B2:D6").Select
  Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With
  With Selection.Borders(xlEdgeTop)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With
  With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With
  With Selection.Borders(xlEdgeRight)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With
  With Selection.Borders(xlInsideVertical)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With
  With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = 3
  End With

'修正したコード
  With Range("B2:D6").Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .Color = vbRed
  End With
'プロパティが既定値(.Weight = xlThin、.ColorIndex = xlAutomatic)の場合
  Range("B2:D6").Borders.LineStyle = xlContinuous
'応用 セル範囲の罫線を消去
  Range("B2:D6").Borders.LineStyle = xlNone
'応用 セル範囲の罫線を消去(隣接セルに罫線がある場合)
  Dim ii&
  For ii = xlDiagonalDown To xlEdgeRight
    Range("C4").Borders(ii).LineStyle = xlNone
  Next

'例6: コメントの書式設定の一'例
'コメントの書式を[フォント]-[スタイル]を"標準"に、[配置]-[自動サイズ調整]をするに設定
'マクロの記録結果
  Range("A1").Comment.Text Text:="Comment"
  With Selection.Font
    .Name = "ＭＳ Ｐゴシック"
    .FontStyle = "標準"
    .Size = 9
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = xlAutomatic
  End With
  With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .Orientation = xlHorizontal
    .AutoSize = True
    .AddIndent = False
  End With

'修正したコード
  Dim rg As Range
  Set rg = Range("A1")
  If rg.Comment Is Nothing Then rg.AddComment
  With rg.Comment
    .Shape.TextFrame.Characters.Font.FontStyle = "標準"
    .Shape.TextFrame.AutoSize = True
    .Text "Comment"
  End With

'例7: 図形描画の'例 (1)
'直線を描き、オートシェイプの書式設定-[色と線]タブ-[線]-[色]を変更
'マクロの記録結果
  ActiveSheet.Shapes.AddLine(124.5, 42.75, 173.25, 96.75).Select
  Selection.ShapeRange.Line.Weight = 0.75
  Selection.ShapeRange.Line.DashStyle = msoLineSolid
  Selection.ShapeRange.Line.Style = msoLineSingle
  Selection.ShapeRange.Line.Transparency = 0#
  Selection.ShapeRange.Line.Visible = msoTrue
  Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
  '以下省略

'修正したコード
  With ActiveSheet.Shapes.AddLine(124.5, 42.75, 173.25, 96.75)
    .Line.ForeColor.SchemeColor = 10
  End With

'例8: 図形描画の'例 (2)
'オートシェイプの文字の編集
'マクロの記録結果
  ActiveSheet.Shapes("AutoShape 1").Select
  Selection.Characters.Text = "abc"

'修正したコード
  ActiveSheet.Shapes("AutoShape 1").TextFrame.Characters.Text = "abc"

'例9: 図形描画の'例 (3)
'オートシェイプ文字のプロパティ設定　[図形挿入]-[テキスト追加]-[色を赤に]-[自動サイズ調整]をチェック
'マクロの記録結果
  ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 20#, 10#, 20, 10#).Select
  Selection.Characters.Text = "TEST"
  With Selection.Characters(Start:=1, Length:=4).Font
    .Name = "ＭＳ Ｐゴシック"
    .FontStyle = "標準"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 3
  End With
  With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .Orientation = xlHorizontal
    .AutoSize = True
    .AddIndent = False
  End With

'修正したコード
  With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 20, 10, 20, 10)
    With .TextFrame.Characters
      .Text = "TEST"
      .Font.Color = vbRed
    End With
    .Parent.DrawingObjects(.Name).AutoSize = True
  End With

'例10: 図形描画の'例 (4)
'全てのシートの図形オブジェクトを削除
'マクロの記録結果
  '[オブジェクトの選択]で選択した場合
  ActiveSheet.Shapes.Range(Array("AutoShape 1", "Rectangle 2")).Select
  Selection.Delete
  Sheets("Sheet2").Select
  '[ジャンプ]-[セル選択]-[オブジェクト]にて選択した場合
  ActiveSheet.DrawingObjects.Select
  Selection.Delete
  Sheets("Sheet3").Select
  ActiveSheet.DrawingObjects.Select
  Selection.Delete
  Sheets("Sheet1").Select

'修正したコード その1
'[ジャンプ]-[セル選択]-[オブジェクト]にて選択されるオブジェクトを削除
'シートの保護(オブジェクト)がされている場合はロックされていないオブジェクトが選択される
'保護がされていない場合は全てのオブジェクトが選択される
  Dim ws As Worksheet
  For Each ws In ActiveWorkbook.Worksheets
    ws.DrawingObjects.Delete
  Next

'修正したコード その2
'シートの保護(オブジェクト)に関わらず明視的にロックされていないオブジェクトのみを削除
  Dim ws As Worksheet, sp As Shape
  For Each ws In ThisWorkbook.Worksheets
    For Each sp In ws.Shapes
      If sp.Locked = False Then sp.DrawingObject.Delete
    Next
  Next

'例11: グラフの一'例
'既存の散布図の[データ系列の書式設定]-[パターン]タブ-[マーカー]-[スタイル]を変更
'マクロの記録結果
  ActiveSheet.ChartObjects("グラフ 1").Activate
  ActiveChart.SeriesCollection(1).Select
  With Selection.Border
    .Weight = xlHairline
    .LineStyle = xlNone
  End With
  With Selection
    .MarkerBackgroundColorIndex = xlAutomatic
    .MarkerForegroundColorIndex = xlAutomatic
    .MarkerStyle = xlCircle
    .Smooth = False
    .MarkerSize = 5
    .Shadow = False
  End With

'修正したコード
  With ActiveSheet.ChartObjects("グラフ 1").Chart
    '
    With .SeriesCollection(1)
      .MarkerStyle = xlCircle
      '
    End With
  End With

'例12: フォームのコントロールの書式設定の一'例
'[フォーム]-[コンボボックス]の[コントロールの書式設定]-[コントロール]タブ-[入力範囲]を設定
'マクロの記録結果
  ActiveSheet.Shapes("Drop Down 1").Select
  With Selection
    .ListFillRange = "$B$2:$B$10"
    .LinkedCell = ""
    .DropDownLines = 8
    .Display3DShading = False
  End With

'修正したコード
  With ActiveSheet.Shapes("Drop Down 1").DrawingObject
  'With ActiveSheet.DropDowns("Drop Down 1") '←別法
    .ListFillRange = "$B$2:$B$10"
    '
  End With
End Sub

ExcelVBA技 全般 E13M013

ExcelVBA技全般 E13M013