セルをPNG画像として保存する

セルをPNG画像として保存する

引用元：セルをPNG画像として保存する

表を選択し図としてコピーする→貼り付ける→
ファイルをhtmlで名前を付けて保存する→htmlファイルと画像を納めたフォルダが出来る

セルに表示されている内容をそのまま画像としたい場合があります。
他の資料の材料としたい場合などですね。
Excelでの操作は以下の手順になります。
1.画像化したいセル範囲を選択します。
2.ホームタブ→コピー→図としてコピー　を選択します。
3.図のコピーダイアログで、画面に合わせる、ピクチャを選択してOKを押します。
4.ホームタブ→貼り付け→形式を選択して貼り付け　を選択して、図（拡張メタファイル）でOKを押します。
5.ファイル→名前を付けて保存　でダイアログを開きます。
6.ファイルの種類でhtmlを選択します。
7.上書き保存で再発行（または発行）を選択して、保存ボタンを押します。
8.Webページとして発行ダイアログで、OKを押します。
9.保存先のフォルダに～filesというフォルダが出来ているのでその中にPNGファイルが作成されています。

【ソースコード】

セルをPNG画像に変換して保存する関数です。
引数が３つあり、それぞれ、引数1＝作成するPNGファイルを保存するフォルダ、引数2＝PNG画像に変換する単一セルまたは結合セル、引数3＝省略可。作成するPNGファイル名の先頭文字列　を指定します。
filesフォルダに「A1_image001.png」という形式のファイルが作成されます。
引数rが単一セルまたは結合セルを指している場合はxx_image001.pngを採用します。セル範囲を指している場合はxx_image004.pngなのかxx_image999.pngなのかどれが正解なのか判別できないためfilesフォルダを残したままにしています。

'// 引数1：sSaveDir＝作成するPNGファイルを保存するフォルダ
'// 引数2：r As Range＝PNG画像に変換するセル。単一セルまたは結合セルを指定する。
'// 引数3：Optional sFileName = "PNG_"＝作成するPNGファイルのファイル名の先頭文字列。省略可。
Sub CellToPng(sSaveDir, r As Range, Optional sFileName = "PNG_")
    Dim oFso            As FileSystemObject
    Dim sDir                                '// 作成フォルダの一部
    Dim sHtmPath                            '// HTMLファイルのフルパス
    Dim oShape                              '// 貼り付けたセルの図
    Dim sAddress                            '// 座標指定用のセル範囲アドレス
    Dim sAddressStr                         '// ファイル名用のセルアドレス
    Dim sPngFileName                        '// PNGファイル名
   
    Application.ScreenUpdating = False
   
    '// 単一セルの場合
    If (r.Count = 1) Then
        '// 結合セルの場合
        If (r.MergeArea.Count > 1) Then
            '// セル範囲アドレスを取得(A1:B2形式)
            sAddress = r.MergeArea.Address(False, False)
           
            '// 引数のセルが結合セルの左上のセルではない場合
            If (Left(sAddress, Len(r.Address(False, False))) <> r.Address(False, False)) Then
                Exit Sub
            End If
        '// 単一セルの場合
        Else
            '// セルアドレスを取得(A1形式)
            sAddress = r.Address(False, False)
        End If
    '// セル範囲の場合
    Else
        sAddress = r.Address(False, False)
    End If
   
    sAddressStr = Replace(sAddress, ":", "")
   
    '// 対象セル範囲を画像としてコピー
    Range(sAddress).CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
    '// 図として貼り付け（オートシェイプ化）
    ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, DisplayAsIcon:=False
   
    '// 図を移動
    Set oShape = Selection
    oShape.Top = r.Top
    oShape.Left = r.Left
   
    '// HTMLファイル名を設定
    sFileName = Replace(sFileName, "/", "\")
    sFileName = Replace(sFileName, "\", "")
    sSaveDir = Replace(sSaveDir, "/", "\")
    If (Right(sSaveDir, 1) = "\") Then
        sSaveDir = Mid(sSaveDir, 1, Len(sSaveDir) - 1)
    End If
    sDir = sSaveDir & "\" & sFileName & sAddressStr
    sDir = Replace(sDir, "/", "\")
    sDir = Replace(sDir, "\\", "\")
    sHtmPath = sDir & ".htm"
   
    '// HTML形式で保存（ファイル名にセルアドレスを付与する）
    With ActiveWorkbook.PublishObjects.Add(xlSourceRange, sHtmPath, r.Parent.Name, r.Address, xlHtmlStatic, sAddressStr)
        .Publish (True)
        .AutoRepublish = False
    End With
   
    '// 作成したオートシェイプを削除
    Selection.Delete
   
    '// 単一セル指定の場合（セル範囲の場合はPNGファイルが複数出力され、image_xxx.pngのどれが正しいのか不明のため選別しない）
    If (r.Count = 1) Then
        Set oFso = New FileSystemObject
        sPngFileName = sAddressStr & "_image001.png"
       
        '// 既に作成済みの場合は再作成するため削除する
        If (oFso.FileExists(sSaveDir & "\" & sPngFileName) = True) Then
            Call oFso.DeleteFile(sSaveDir & "\" & sPngFileName)
        End If
       
        '// PNGファイルを移動（PNG_A1.filesフォルダから上階層に移動）
        Call oFso.MoveFile(sDir & ".files\" & sPngFileName, sSaveDir & "\" & sPngFileName)
       
        '// PNG_A1.filesフォルダを削除
        Kill sDir & ".files\*"
        RmDir sDir & ".files"
    End If
   
    '// .htmファイルを削除
    Kill sHtmPath
   
    Application.ScreenUpdating = True
End Sub

【テストコード】

上の関数を呼び出すテストコードです。
5行目のループは選択範囲を各セルごとにPNGファイル化しています。
6行目と7行目が上の関数を呼び出す部分です。6行目はコメントアウトしていますが、PNGファイル名の先頭文字を3番目の引数として渡しています。7行目のように省略しても構いません。省略時はPNGファイル名の先頭に「PNG_」と付きます。
11行目は選択範囲をPNGファイル化しています。

Sub CellToPngTest()
    Dim r As Range
   
    '// A1からC1の各セルをPNGファイル化
    For Each r In Selection
'        Call CellToPng("C:\web\test\", r, "\ABC\")
        Call CellToPng("C:\web\test\", r)
    Next
   
    '// A1からC1のセル範囲PNGファイル化
    Call CellToPng("C:\web\test\", Selection)
End Sub

【マクロ】セルに数式を記入する方法

↓エラーが出る書き方
Range("A1") = "=LEFT("tanaka",2)"

文字列は""(ダブルコーテーション)で囲みます。逆に言えば、""(ダブルコーテーション)で囲まれているのは文字列と認識されます。すると、数式として入力しようとしたデータは、「=LEFT(」という文字列＋「tanaka」というコマンド名＋「,2)」という文字列という訳の分からないデータになってしまいます。
「tanaka」を囲む""(ダブルコーテーション)を、文字列の区切りである""(ダブルコーテーション)ではなく、単なるデータとしての""(ダブルコーテーション)とするには、""(ダブルコーテーション)を2つ重ねて記述します。

参照：数式の入力

Range("A1") = "=LEFT(""tanaka"",2)"

これで正しく「=LEFT("tanaka",2)」という数式を入力できます。

ワークシート関数には""(ダブルコーテーション)がひんぱんに使われます。マクロでセルに入力するときには、十分注意して下さい。

参照：数式の入力

【Blender】拡大縮小の時の中心

デフォルトではピボットポイントがアクティブ要素になっているため
拡大縮小をするときにミラーを入れていると割れたり重なったりする。※図1
ピボットポイントを3Dカーソルにすると3Dカーソル(紅白の円)を中心に
拡大縮小できる。※図2・3




図1

図2

図3

【マクロ】A列に値があればB列に連番を入れる

A列に値があればB列に連番を入れる

Sub Macro1()
    Dim i As Long
    Dim N As Long
    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If Cells(i, "A").Value <> "" Then
            N = N + 1
            Cells(i, "B").Value = N
        End If
    Next i
End Sub



A列に値があればB列にその日の日付を入れる

Sub Macro2()
    Dim i As Long
    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If Cells(i, "A").Value <> "" Then
            Cells(i, "B").Value = Date
        End If
    Next i
End Sub

【関数】列の最後の値を取得

他にもやり方有るが一番簡単

=INDIRECT("A"&COUNTA(A:A))

【マクロ】セルの数式が計算された時に実行されるイベントプロシージャ

セルの数式が計算された時に実行されるイベントプロシージャとして Worksheet_Calculate イベントがあります。
これを活用されると良いでしょう。

監視対象セル以外のセル範囲に数式が設定されていると、その再計算時にもイベントが発生しますので
別に作業用シートを用意したほうが無難。

例えば Sheet1 の X10 セルの関数の戻り値を監視したい場合。
1)新規シートを追加して、監視用シートとする。
2)追加した監視用シートの A1 セルに 数式で =Sheet1!X10 ..などのように監視対象のセルを参照。
3)監視用シートのシートモジュールに以下のプロシージャを置く。
Private Sub Worksheet_Calculate()
　　If Range("A1").Value <> Range("B1").Value Then
　　　　Range("B1").Value = Range("A1").Value
　　　　MsgBox "change"
　　End If
End Sub

基本的に、Sheet1 の X10 セルの数式が計算されて値が変化した時にCalculateイベントが発生しますが、
数式の内容によっては、値が変わらなくてもCalculateイベントが発生するケースもあります。
また、Sheet1の行削除や挿入時などでもCalculateイベントは反応します。
なので前回計算時の値を別セルに記憶させておいて、値を比較する必要があります。
前述の例では、A1に参照数式があるとして、B1セルを記憶用セルとして使うようにしています。

【マクロ】エクセルの行列幅のみコピペ

通常では形式の貼り付けで列幅だけは貼り付けられるが、
行幅だけはコピペ出来ない。

まずは貼り付けたい箇所を選択し下記のマクロを実行する。
貼り付け先を指定するインプットボックスが出るので
直接入力するか、貼りたい場所をクリックする。
A1：G50を選択し、貼り付け先をB1にする。
この時は行幅だけ反映される。
A1：G50を選択し、貼り付け先をB列を指定する。
これで行、列幅共に反映される。

※貼り付け先を別ブックでも指定できるが行幅だけしか反映されないので
　貼り付け後に形式を選択して貼り付けで列幅を貼ればよい。

Sub 列幅も行高もコピー()
    'コピーする範囲を選択してから実行
    Dim i As Long
    Dim gyosu As Long
    Dim myRange As Range
    Dim doko As Range
    Dim saki As Range
    Set myRange = Selection
    gyosu = myRange.Rows.Count
    ActiveSheet.Select
    Set doko = Application.InputBox("コピー先の先頭セルを選択", Type:=8)
    Set saki = doko.Resize(gyosu, myRange.Columns.Count)
    myRange.Copy
    Range(doko.Address).Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False
    For i = 1 To gyosu
        saki.Rows(i).RowHeight = myRange.Rows(i).RowHeight
    Next
End Sub