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

 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

【マクロ】選択した範囲のアドレスを取得する

シート上で実際に選択した範囲からそのアドレスを取り出す方法

標準モジュールに
Sub rangeaddress()
Range(g_cnsclearrange).ClearContents
End Sub

イミディエイトウィンドウに
?selection.address
と、入力してEnterを押す
結果
?selection.address
$B$4:$C$6,$E$4,$F$7:$F$8
と、書き出される。

結合された範囲でも取得が出来る。


※注意点
まず、選択したセル範囲のアドレスが表記上であまりにも長い(限度は未確認ですが)場合、「イディミエイトウィンドウ」上に全てが表示されない場合がある。
 このような場合は、表示されるアドレス文字列の右端が最後に選択したセル(セル範囲)かどうか確認すること。
もう一つ、Rangeプロパティに指定できるセル範囲を示す文字列の長さにも限度があり、
これを超えていると実行時にエラーとなる。
この場合は、文字列を複数に分けて順に利用するように。

【マクロ】RGB色見本を作成するマクロ

Sub RGB値色見本作成()
  Dim rr As Long, gg As Long, bb As Long
  Dim r As Long: r = 1  ' 行番号
  Dim c As Long: c = 1  ' 列番号
  For rr = 0 To 255 Step 51
    For gg = 0 To 255 Step 51
      For bb = 0 To 255 Step 51
        With Cells(r, c)
          .Interior.Color = RGB(rr, gg, bb)
          .Value = "#" & _
            Format(Hex(rr), "00") & _
            Format(Hex(gg), "00") & _
            Format(Hex(bb), "00")
        End With
        r = r + 1
      Next bb
      r = r - 6
      c = c + 1
    Next gg
    r = r + 6
    c = c - 6
  Next rr
  Columns("A:F").AutoFit
End Sub

【マクロ】抽出に利用している項目名を取得する

オートフィルターで絞っている列の項目名を抽出する。



Sub 絞り込みを行っているフィールド名を調べる()

　Dim aft As AutoFilter
　Dim fld As String　' フィールド名
　Dim i As Long
　If Not ActiveSheet.FilterMode Then Exit Sub
　Set aft = ActiveSheet.AutoFilter
　For i = 1 To aft.Filters.Count
　　If aft.Filters(i).On Then
　　　fld = fld & _
'　　　　aft.Range.Cells(1, i).Value & vbCrLf　'改行して表示
　　　　aft.Range.Cells(1, i).Value & "/"　'スラッシュで区切って表示
　　End If
　Next i

　  Worksheets("Sheet1").Select
    Range("H3") = fld　　'値を返す
'右側から一文字削除する
    Range("H3") = Mid(Range("H3"), 1, Len(Range("H3")) - 1)
End Sub

【マクロ】フィルター後に特定列のコピペ

With Sheets("Sheet1")
.Range(.Range("Q2"), .Range("Q" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet2").Range("C2").PasteSpecial Paste:=xlPasteValues
End With


.Range(.Range("A2"), .Range("D" &
とすると、A列からD列となる。