xlogI125’s blog

パソコン作業を効率化したい

Excelセルの値を座標としてワークシートに描画

以下の方法で曲線を描画する

  • Shapes.AddCurveメソッド
  • FreeformBuilder.AddNodesメソッド (EditingTypemsoEditingCornerとする)

座標例

EditingType SegmentType Ox Oy X Y C1x C1y C2x C2y
Corner - 5 10 0 0 - - - -
Corner Curve 5 10 3 1 1 5 2 -4
Corner Curve 5 10 6 0 4 3 5 -2
Corner Curve 5 10 9 -1 7 4 8 -3
Corner Curve 5 10 12 0 10 1 11 -5

使い捨てマクロ

' Excel 2019, Windows 11 (2024年5月頃)

' 参照設定
' Microsoft Office 16.0 Object Library

' セルの選択範囲は10列で2行以上とする
'  1列目 EditingType (Auto, Corner, Smooth, Symmetric)
'  2列目 SegmentType (Curve, Line)
'  3列目 Ox [cm]
'  4列目 Oy [cm]
'  5列目 X  [cm]
'  6列目 Y  [cm]
'  7列目 C1x[cm]
'  8列目 C1y[cm]
'  9列目 C2x[cm]
' 10列目 C2y[cm]

' 「新しいウィンドウを開く」でウィンドウを複数表示させると作業効率が向上すると思います

Option Explicit

Public Sub DrawCurve()
  Dim rngDat As Excel.Range
  Dim rng As Excel.Range
  Dim wb As Excel.Workbook
  Dim shtFig As Excel.Worksheet
  Dim shpFig As Excel.Shape
  Dim pointPt() As Single
  Dim oxPt As Single, oyPt As Single
  Dim xPt As Single, yPt As Single
  Dim c1xPt As Single, c1yPt As Single
  Dim c2xPt As Single, c2yPt As Single
  Dim i As Long

  Set rngDat = Excel.Application.ActiveWindow.RangeSelection

  If rngDat.Columns.Count <> 10 Or rngDat.Rows.Count < 2 Then
    VBA.Interaction.MsgBox Prompt:="セルの選択範囲は10列で2行以上としてください"
    Exit Sub
  End If

  SetValidFmtCond rngDat

  Set wb = rngDat.Worksheet.Parent

  Set shtFig = Nothing

  On Error Resume Next
  Set shtFig = wb.Worksheets.Item("fig")
  On Error GoTo 0

  If shtFig Is Nothing Then
    Set shtFig = wb.Worksheets.Add()
    shtFig.Name = "fig"
  Else
    shtFig.Visible = Excel.XlSheetVisibility.xlSheetVisible
  End If

  ReDim pointPt(1 To 1 + 3 * (rngDat.Rows.Count - 1), 1 To 2)

  For i = 1 To rngDat.Rows.Count Step 1
    VBA.Interaction.DoEvents

    Set rng = rngDat.Cells.Item(i, 3)
    oxPt = rng.Value2 * 72 / 2.54
    Set rng = rngDat.Cells.Item(i, 4)
    oyPt = rng.Value2 * 72 / 2.54
    Set rng = rngDat.Cells.Item(i, 5)
    xPt = rng.Value2 * 72 / 2.54
    Set rng = rngDat.Cells.Item(i, 6)
    yPt = rng.Value2 * 72 / 2.54

    If i = 1 Then
      ' 1行目
      pointPt(1, 1) = oxPt + xPt
      pointPt(1, 2) = oyPt - yPt
    Else
      ' 2行目以降
      Set rng = rngDat.Cells.Item(i, 7)
      c1xPt = rng.Value2 * 72 / 2.54
      Set rng = rngDat.Cells.Item(i, 8)
      c1yPt = rng.Value2 * 72 / 2.54
      Set rng = rngDat.Cells.Item(i, 9)
      c2xPt = rng.Value2 * 72 / 2.54
      Set rng = rngDat.Cells.Item(i, 10)
      c2yPt = rng.Value2 * 72 / 2.54

      pointPt(3 * (i - 2) + 2, 1) = oxPt + c1xPt
      pointPt(3 * (i - 2) + 2, 2) = oyPt - c1yPt
      pointPt(3 * (i - 2) + 3, 1) = oxPt + c2xPt
      pointPt(3 * (i - 2) + 3, 2) = oyPt - c2yPt
      pointPt(3 * (i - 2) + 4, 1) = oxPt + xPt
      pointPt(3 * (i - 2) + 4, 2) = oyPt - yPt
    End If
  Next i

  Set shpFig = shtFig.Shapes.AddCurve(SafeArrayOfPoints:=pointPt)
  shpFig.Fill.Visible = Office.MsoTriState.msoFalse
End Sub


Public Sub DrawFreeform()
  Dim rngDat As Excel.Range
  Dim rng As Excel.Range
  Dim wb As Excel.Workbook
  Dim shtFig As Excel.Worksheet
  Dim ffb As Excel.FreeformBuilder
  Dim shpFig As Excel.Shape
  Dim oxPt As Single, oyPt As Single
  Dim xPt As Single, yPt As Single
  Dim c1xPt As Single, c1yPt As Single
  Dim c2xPt As Single, c2yPt As Single
  Dim strEditingType As String, strSegmentType As String
  Dim eType As Long, sType As Long
  Dim i As Long

  Set rngDat = Excel.Application.ActiveWindow.RangeSelection

  If rngDat.Columns.Count <> 10 Or rngDat.Rows.Count < 2 Then
    VBA.Interaction.MsgBox Prompt:="セルの選択範囲は10列で2行以上としてください"
    Exit Sub
  End If

  SetValidFmtCond rngDat

  Set wb = rngDat.Worksheet.Parent

  Set shtFig = Nothing

  On Error Resume Next
  Set shtFig = wb.Worksheets.Item("fig")
  On Error GoTo 0

  If shtFig Is Nothing Then
    Set shtFig = wb.Worksheets.Add()
    shtFig.Name = "fig"
  Else
    shtFig.Visible = Excel.XlSheetVisibility.xlSheetVisible
  End If

  For i = 1 To rngDat.Rows.Count Step 1
    VBA.Interaction.DoEvents

    Set rng = rngDat.Cells.Item(i, 1)
    strEditingType = rng.Value2

    Select Case strEditingType
      Case "Auto"
        eType = Office.MsoEditingType.msoEditingAuto
      Case "Corner"
        eType = Office.MsoEditingType.msoEditingCorner
      Case "Smooth"
        eType = Office.MsoEditingType.msoEditingSmooth
      Case "Symmetric"
        eType = Office.MsoEditingType.msoEditingSymmetric
      Case Else
        eType = Office.MsoEditingType.msoEditingAuto
    End Select

    Set rng = rngDat.Cells.Item(i, 3)
    oxPt = rng.Value2 * 72 / 2.54

    Set rng = rngDat.Cells.Item(i, 4)
    oyPt = rng.Value2 * 72 / 2.54

    Set rng = rngDat.Cells.Item(i, 5)
    xPt = rng.Value2 * 72 / 2.54

    Set rng = rngDat.Cells.Item(i, 6)
    yPt = rng.Value2 * 72 / 2.54

    If i = 1 Then
      ' 座標の1点目
      Set ffb = shtFig.Shapes.BuildFreeform(editingType:=eType, X1:=oxPt + xPt, Y1:=oyPt - yPt)
    Else
      ' 座標の2点目以降
      Set rng = rngDat.Cells(i, 2)
      strSegmentType = rng.Value2

      Select Case strSegmentType
        Case "Curve"
          sType = Office.MsoSegmentType.msoSegmentCurve
        Case "Line"
          sType = Office.MsoSegmentType.msoSegmentLine
        Case Else
          sType = Office.MsoSegmentType.msoSegmentLine
      End Select

      Set rng = rngDat.Cells.Item(i, 7)
      c1xPt = rng.Value2 * 72 / 2.54

      Set rng = rngDat.Cells.Item(i, 8)
      c1yPt = rng.Value2 * 72 / 2.54

      Set rng = rngDat.Cells.Item(i, 9)
      c2xPt = rng.Value2 * 72 / 2.54

      Set rng = rngDat.Cells.Item(i, 10)
      c2yPt = rng.Value2 * 72 / 2.54

      If eType <> Office.MsoEditingType.msoEditingCorner Then
        ffb.AddNodes segmentType:=sType, editingType:=eType, X1:=oxPt + xPt, Y1:=oyPt - yPt
      Else
        ffb.AddNodes segmentType:=sType, editingType:=eType, X1:=oxPt + c1xPt, Y1:=oyPt - c1yPt, X2:=oxPt + c2xPt, Y2:=oyPt - c2yPt, X3:=oxPt + xPt, Y3:=oyPt - yPt
      End If
    End If
  Next i

  Set shpFig = ffb.ConvertToShape()
  shpFig.Fill.Visible = Office.MsoTriState.msoFalse
End Sub


Public Sub SetValidFmtCond(ByRef rngDat As Excel.Range)
  Dim rng As Excel.Range
  Dim fmtCond As Excel.FormatCondition

  Set rng = rngDat.Worksheet.Cells
  With rng
    .Validation.Delete
    .FormatConditions.Delete
  End With

  ' 1列目(EditingType)の入力規則と条件付き書式
  Set rng = rngDat.Columns.Item(1)
  With rng
    With .Validation
      .Add Type:=Excel.XlDVType.xlValidateList, AlertStyle:=Excel.XlDVAlertStyle.xlValidAlertInformation, Formula1:="Auto, Corner, Smooth, Symmetric"
      .IgnoreBlank = False
      .InCellDropdown = True
      .ShowInput = False
    End With
    With .FormatConditions
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Auto"""
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Corner"""
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Smooth"""
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Symmetric"""
    End With
    For Each fmtCond In .FormatConditions
      fmtCond.Interior.Color = VBA.Information.RGB(Red:=192, Green:=255, Blue:=192)
      fmtCond.StopIfTrue = True
    Next fmtCond
  End With

  ' 座標の1点目にSegmentTypeは該当しない
  Set rng = Excel.Application.Union(rngDat.Cells.Item(1, 2), rngDat.Cells.Item(1, 7), rngDat.Cells.Item(1, 8), rngDat.Cells.Item(1, 9), rngDat.Cells.Item(1, 10))
  With rng
    With .FormatConditions
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlNotEqual, Formula1:="="""""
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="="""""
    End With
    For Each fmtCond In .FormatConditions
      fmtCond.Interior.Color = VBA.Information.RGB(Red:=192, Green:=192, Blue:=192)
      fmtCond.StopIfTrue = True
    Next fmtCond
  End With

  ' 座標の2点目以降におけるSegmentTypeの入力規則と条件付き書式
  Set rng = rngDat.Worksheet.Range(rngDat.Cells.Item(2, 2), rngDat.Cells.Item(rngDat.Rows.Count, 2))
  With rng
    With .Validation
      .Add Type:=Excel.XlDVType.xlValidateList, AlertStyle:=Excel.XlDVAlertStyle.xlValidAlertInformation, Formula1:="Curve, Line"
      .IgnoreBlank = False
      .InCellDropdown = True
      .ShowInput = False
    End With
    With .FormatConditions
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Curve"""
      .Add Type:=Excel.XlFormatConditionType.xlCellValue, Operator:=Excel.XlFormatConditionOperator.xlEqual, Formula1:="=""Line"""
    End With
    For Each fmtCond In .FormatConditions
      fmtCond.Interior.Color = VBA.Information.RGB(Red:=192, Green:=255, Blue:=192)
      fmtCond.StopIfTrue = True
    Next fmtCond
  End With
End Sub

Excel VBA練習 Excelセルの値を座標としてPowerPointスライドに描画 2

Excelセルの値を座標としてPowerPointスライドにフリーフォームを追加する使い捨てマクロ。

数式例

円弧

A B C D
1 = 0.5 + 0.1 * COS( PI()/2 - PI()/16*(ROW(A1)-1) ) = 0.1 + 0.1 * SIN( PI()/2 - PI()/16*(ROW(A1)-1) ) Auto Curve
A B C D
1 = -0.5 + 0.1 * COS( PI()/2 + PI()/16*(ROW(A1)-1) ) = -0.1 + 0.1 * SIN( PI()/2 + PI()/16*(ROW(A1)-1) ) Auto Curve

A B C D
0.5 0 Auto Line
0 0 Auto Line

その他

A B C D
1 1 Corner Curve
1 -1 Corner Curve
-1 -1 Corner Curve
-1 1 Corner Curve
1 1 Corner Curve


A B C D
1 1 Auto Curve
1 -1 Auto Curve
-1 -1 Auto Curve
-1 1 Auto Curve
1 1 Auto Curve


使い捨てマクロ

GetObject関数でPowerPoint.Applicationオブジェクトへの参照を取得してスライドに書き込みを行うため、起動している不要なPowerPointを終了してください。

' Excel 2019, PowerPoint 2019, Windows 11 (2024年5月頃)

' 参照設定
' Microsoft Office 16.0 Object Library
' Microsoft PowerPoint 16.0 Object Library

' セルの選択範囲は4列で2行以上とする
' 1列目 ... X[cm]
' 2列目 ... Y[cm]
' 3列目 ... EditingType (文字列で Auto  または Corner)
' 4列目 ... SegmentType (文字列で Curve または Line  )

Option Explicit

#Const DEBUG_ = False

Public Sub Main()
  Dim xlRng As Excel.Range
  Dim N As Long
  Dim ppPts() As Single
  Dim ppPtsEditType() As Long, ppPtsSegType() As Long
  Dim i As Long
  Dim strEditingType As String, strSegmentType As String
  Dim msg As String, msgErr As New VBA.Collection

#If DEBUG_ Then
  Dim ppApp As PowerPoint.Application
  Dim ppPr As PowerPoint.Presentation
  Dim ppSld As PowerPoint.Slide
  Dim ppFfb As PowerPoint.FreeformBuilder
  Dim ppShp As PowerPoint.Shape
#Else
  Dim ppApp As Object
  Dim ppPr As Object
  Dim ppSld As Object
  Dim ppFfb As Object
  Dim ppShp As Object
#End If

  Set xlRng = Excel.Application.ActiveWindow.RangeSelection

  If xlRng.Columns.Count <> 4 Then
    VBA.Interaction.MsgBox Prompt:="選択範囲は4列にしてください"
    Exit Sub
  End If

  N = xlRng.Rows.Count

  If N < 2 Then
    VBA.Interaction.MsgBox Prompt:="選択範囲は2行以上にしてください"
    Exit Sub
  End If

  On Error Resume Next
  ' 既に起動されているPowerPointを取得
  Set ppApp = VBA.Interaction.GetObject(Class:="PowerPoint.Application")
  On Error GoTo 0

  If ppApp Is Nothing Then
    ' PowerPointを新たに起動
    Set ppApp = VBA.Interaction.CreateObject("PowerPoint.Application")
    ppApp.Visible = Office.MsoTriState.msoTrue
    ' プレゼンテーションを追加
    Set ppPr = ppApp.Presentations.Add
    ' PowerPointスライドのサイズを横20cm、縦10cmとする
    ppPr.PageSetup.SlideWidth = 20 * 72 / 2.54
    ppPr.PageSetup.SlideHeight = 10 * 72 / 2.54
    ' PowerPointスライドのグリッドを0.1cmに設定
    ppPr.GridDistance = 0.1 * 72 / 2.54
    ppPr.Application.DisplayGridlines = Office.MsoTriState.msoTrue
    ' スライドを追加
    Set ppSld = ppPr.Slides.AddSlide(Index:=1, pCustomLayout:=ppPr.Designs(1).SlideMaster.CustomLayouts(7))
  Else
    Set ppSld = ppApp.ActiveWindow.Selection.SlideRange(1)
    Set ppPr = ppSld.Parent
  End If

  ReDim ppPts(1 To N, 1 To 2)
  ReDim ppPtsEditType(1 To N)
  ReDim ppPtsSegType(1 To N)

  For i = 1 To N Step 1
    VBA.Interaction.DoEvents

    ' PowerPointスライド中央の座標を(X,Y)=(0,0)とし、右方向にXを正、上方向にYを正とする。

    ' 1列目 ... X[cm]
    ppPts(i, 1) = ppPr.PageSetup.SlideWidth * 0.5 + xlRng.Cells(i, 1).Value2 * 72 / 2.54
    ' 2列目 ... Y[cm]
    ppPts(i, 2) = ppPr.PageSetup.SlideHeight * 0.5 - xlRng.Cells(i, 2).Value2 * 72 / 2.54
    ' 3列目 ... EditingType (Auto, Corner)
    strEditingType = xlRng.Cells(i, 3).Value2
    Select Case strEditingType
      Case "Auto"
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingAuto
      Case "Corner"
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingCorner
      Case Else
        ppPtsEditType(i) = Office.MsoEditingType.msoEditingAuto
        msgErr.Add Item:="行" & i & ": EditingType """ & strEditingType & """"
    End Select
    ' 4列目 ... SegmentType (Curve, Line)
    If i >= 2 Then
      strSegmentType = xlRng.Cells(i, 4).Value2
      Select Case strSegmentType
        Case "Curve"
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentCurve
        Case "Line"
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentLine
        Case Else
          ppPtsSegType(i) = Office.MsoSegmentType.msoSegmentLine
          msgErr.Add Item:="行" & i & ": SegmentType """ & strSegmentType & """"
      End Select
    End If
  Next i

  ' 座標の1点目
  Set ppFfb = ppSld.Shapes.BuildFreeform(EditingType:=ppPtsEditType(1), X1:=ppPts(1, 1), Y1:=ppPts(1, 2))

  ' 座標の2点目以降
  For i = 2 To N Step 1
    ppFfb.AddNodes SegmentType:=ppPtsSegType(i), EditingType:=ppPtsEditType(i), X1:=ppPts(i, 1), Y1:=ppPts(i, 2)
  Next i

  Set ppShp = ppFfb.ConvertToShape()
  ppShp.Fill.Visible = Office.MsoTriState.msoFalse

  msg = ""

  For i = 1 To msgErr.Count Step 1
    msg = msg & VBA.Constants.vbCrLf & msgErr(i)
  Next i

  VBA.Interaction.MsgBox Prompt:="描画完了" & VBA.Constants.vbCrLf & msg
End Sub

過去記事

dy100ms.hatenadiary.jp

Excel VBA: フォルダ内にあるファイルのパスを取得

Get-ChildItemコマンドレットの結果をクリップボード経由でワークシートに貼り付けたほうが早いけど、Excel VBAを使用しての方法を考える。

# PowerShell 5.1, Windows 11 (2024年4月頃)
$fileInfos = Get-ChildItem -File -Force -Recurse -Depth 1 -LiteralPath "${env:USERPROFILE}\Desktop"
$fileInfos.FullName | Sort-Object | Set-Clipboard
' Excel 2019, Windows 11 (2024年4月頃)

' 参照設定
' Microsoft Office 16.0 Object Library
' Microsoft Scripting Runtime

Option Explicit

Public Sub GetFilePath(ByRef paths As VBA.Collection, ByRef folder As Scripting.Folder, ByVal depth As Long)
  Dim f As Scripting.File
  Dim d As Scripting.Folder

  If depth < 0 Then
    Exit Sub
  End If

  On Error GoTo ErrorHandler

  For Each f In folder.Files
    Call paths.Add(Item:=f.Path)
  Next f

  For Each d In folder.SubFolders
    Call GetFilePath(paths, d, depth - 1)
  Next d

  Exit Sub

ErrorHandler:
  Debug.Print folder.Path
  Debug.Assert False

End Sub

Public Sub Main()
  Dim fso As Scripting.FileSystemObject
  Dim dlg As Office.FileDialog
  Dim fld As Scripting.Folder
  Dim paths As VBA.Collection
  Dim depth As Long
  Dim arr2dPath() As String
  Dim sht As Excel.Worksheet
  Dim rng As Excel.Range
  Dim i As Long

  ' FileSystemObject
  Set fso = VBA.Interaction.CreateObject(Class:="Scripting.FileSystemObject")

  ' FolderPicker
  Set dlg = Excel.Application.FileDialog(FileDialogType:=Office.MsoFileDialogType.msoFileDialogFolderPicker)
  dlg.Title = "フォルダ選択"
  dlg.InitialFileName = VBA.Interaction.Environ(Expression:="USERPROFILE") & "\Desktop\"

  If dlg.Show = 0 Then
    Call Err.Raise(Number:=513, Description:="フォルダが選択されていません")
    Exit Sub
  End If

  ' Folderオブジェクト
  Set fld = fso.GetFolder(FolderPath:=dlg.SelectedItems.Item(1))

  ' ファイルのパスを入れるコレクション
  Set paths = New VBA.Collection

  ' InputBoxメソッドで再帰の深さを入力
  depth = Excel.Application.InputBox(Prompt:="depth", Title:="再帰の深さ", Default:=1, Type:=1)

  ' ファイルのパスを取得
  Call GetFilePath(paths, fld, depth)

  If paths.Count = 0 Then
    Call Err.Raise(Number:=514, Description:="ファイルがありません")
    Exit Sub
  End If

  ' セルに値を設定するための2次元配列
  ReDim arr2dPath(1 To paths.Count, 1 To 1)

  ' コレクションから2次元配列にコピー
  For i = 1 To UBound(arr2dPath, 1) Step 1
    arr2dPath(i, 1) = paths.Item(i)
  Next i

  ' ワークシートのセル範囲を取得
  Set sht = Excel.Application.ActiveWindow.ActiveSheet
  Set rng = sht.Range(sht.Cells.Item(1, 1), sht.Cells.Item(UBound(arr2dPath, 1), 1))

  ' 2次元配列の値をセル範囲の値に設定
  rng.Value2 = arr2dPath

  ' 並べ替え
  Call rng.Sort( _
    Key1:=rng.Columns.Item(1), _
    Order1:=Excel.XlSortOrder.xlAscending, _
    Header:=Excel.XlYesNoGuess.xlNo, _
    MatchCase:=False, _
    Orientation:=Excel.XlSortOrientation.xlSortColumns, _
    SortMethod:=Excel.XlSortMethod.xlPinYin, _
    DataOption1:=Excel.XlSortDataOption.xlSortNormal _
  )
End Sub