【マクロ】複数ファイルを別フォルダにコピーする

 Sub 複数のファイルをコピー()

'Dドライブのabcフォルダにある全てのcsvファイルを

'Dドライブのxyzフォルダにコピーする

Dim cop As Object

Set cop = CreateObject("Scripting.FileSystemObject")

cop.CopyFile "\D:\abc\*.csv", "D:\xyz\"

Set cop = Nothing

End Sub

【マクロ】フォルダ内の画像を一括で貼り付ける

 Sub フォルダ内の画像を一括で貼り付けるマクロ()

  

  'マクロを起動するとインプットボックスが立ち上がり

  '画像を貼り付ける開始位置（開始セル）をマウスで選択する

  '画像の大きさはセルの大きさに合わせて、挿入時に自動的に調整される

  

  

  Dim i As Long, j As Long, k As Long

  Dim FileName As Variant

  Dim dblscal As Double

  Dim sp As Shape

  

  FileName = Application.GetOpenFilename( _

     filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _

     MultiSelect:=True)

     

  Dim inp As Range

  On Error Resume Next

  Set inp = Application.InputBox( _

     prompt:="マウスで開始セルを選択してください", _

     Title:="開始セルを選択", _

     Default:="マウスで開始セルを選択する", _

     Type:=8)         ''←メッセージボックスで開始セルを選択させる

     

  If Err.Number = 0 Then

     MsgBox mayrange.Address

  Else

     MsgBox "キャンセルしました。"

  End If

  

  j = inp.Row      ''←選択した開始セルの行

  k = inp.Column   ''←選択した開始セルの列

  

  For i = LBound(FileName) To UBound(FileName)

     Cells(j, k).Select

     With ActiveSheet.Shapes.AddPicture( _

        FileName:=FileName(i), _

        linktofile:=False, _

        savewithdocument:=True, _

        Left:=Selection.Left, _

        Top:=Selection.Top, _

        Width:=0, _

        Height:=0)

        

     .ScaleHeight 1, msoTrue

     .ScaleWidth 1, msoTrue

     

     If Cells(j, k).Width / .Width < Cells(j, k).Height / .Height Then

        dblscal = WorksheetFunction.RoundDown(Cells(j, k).Width / .Width, 2)

     Else

        dblscal = WorksheetFunction.RoundDown(Cells(j, k).Height / .Height, 2)

     End If

     

     .Width = .Width * dblscal * 0.97

     .Height = .Height * dblscal * 0.97

     .Left = .Left + (Cells(j, k).Width - .Width) / 2

     .Top = .Top + (Cells(j, k).Height - .Height) / 2

     End With

     

     k = k + 1

     If k > 1 Then   ''←折り返しの列はここを変える

        k = 1

        j = j + 1

     End If

    

  Next i

End Sub

その他、参考になるサイト

https://kantan-shikaku.com/ks/insertimages/

【マクロ】隣接する同じ値のセルを結合する

Sub 同じデータのセルを結合する()

Dim 列 As Long

Dim 行 As Long

Dim 行終 As Long

Dim 列終 As Long

Dim myUni As Range

Application.DisplayAlerts = False

If Selection.Rows.Count > 1 And Selection.Columns.Count = 1 Then    '下方向に選択したときの処理

    列 = Selection.Column

    行 = Selection.Row + 1

    行終 = Selection.Rows(Selection.Rows.Count).Row

    

    Do While 行 <= 行終

        If Cells(行 - 1, 列).MergeArea(1).Value = Cells(行, 列).MergeArea(1).Value Then

            If myUni Is Nothing Then

                Set myUni = Range(Cells(行 - 1, 列), Cells(行, 列))

            Else

                Set myUni = Union(myUni, Cells(行, 列))

            End If

        Else

            If Not myUni Is Nothing Then

                myUni.Merge

                Set myUni = Nothing

            End If

        End If

        

        行 = 行 + 1

    Loop

        

ElseIf Selection.Rows.Count = 1 And Selection.Columns.Count > 1 Then '右方向に選択したときの処理

    行 = Selection.Row

    列 = Selection.Column + 1

    列終 = Selection.Columns(Selection.Columns.Count).Column

    

    Do While 列 <= 列終

        If Cells(行, 列 - 1).MergeArea(1).Value = Cells(行, 列).MergeArea(1).Value Then

            If myUni Is Nothing Then

                Set myUni = Range(Cells(行, 列 - 1), Cells(行, 列))

            Else

                Set myUni = Union(myUni, Cells(行, 列))

            End If

        Else

            If Not myUni Is Nothing Then

                myUni.Merge

                Set myUni = Nothing

            End If

        End If

        

        列 = 列 + 1

    Loop

    

End If

If Not myUni Is Nothing Then    '行終または列終を含むセルの結合

    myUni.Merge

End If

End Sub

【マクロ】 グラフ凡例のサイズ変更

Sub グラフ凡例のサイズ変更()

'基本とするグラフをアクティブにして実行する

Dim objChart As Object

Dim LegendLeft As Single

Dim LegendTop As Single

Dim LegendHeight As Single

Dim Lengend As Single

On Error GoTo ErrorHandler

If ActiveChart Is Nothing Then

MsgBox "アクティブなグラフがありません"

Exit Sub

End If

'アクティブチャートの凡例のサイズを取得します

With ActiveChart.Legend

LegendLeft = .Left

LegendTop = .Top

LegendHeight = .Height

legendwidth = .Width

End With

'全てのチャートの凡例サイズを上で取得した値にする

For Each objChart In ActiveSheet.ChartObjects

With objChart.Chart.Legend

.Left = LegendLeft

.Top = LegendTop

.Height = LegendHeight

.Width = legendwidth

.Format.TextFrame2.TextRange.Font.Size = 9 'フォントサイズ

End With

Next

ErrorHandler:

Exit Sub

End Sub