【必携Function-1】【エクセル2013,VBA】
新しくエクセルのアプリケーションを作る際には、便利なFunctionの一群をまずはごっそり移すところからはじめます。
以下、必携のファンクションを紹介します。
1.GetDeskTopPath
デスクトップのパスを取得するファンクション。例えば↓のような使い方をします。
デスクトップのパスをデフォルトの保存場所などにしておくと、不特定のPCでも動作するファイルになります。
Thisworkbook.pathも同じような目的で使用します。また「("Desktop")」を変更すればマイドキュメント等のパスの取得も可能です。
2.GetUserName,GetComputerName
user nameやコンピュターnameを取得するファンクション。例えば↓のような使い方をします。
社用PCなどuser nameと利用者情報の対応表が存在する場合、このファンクションを利用して利用者情報の自動入力補助ができるようになります。
3.SelectFold,SelectFile
ダイヤログボックスからフォルダやファイルを指定（＝パスを取得）できます。
動的なアプリケーションに必須です。
動的にしておくと、様々なデータやファイルで検証しやすいのでテストの際などにも便利です。
Sub 動作確認() MsgBox "Functionの動作確認 " MsgBox GetDeskTopPath MsgBox GetUserName MsgBox GetComputerName MsgBox SelectFold MsgBox SelectFile End Sub Function GetDeskTopPath() 'デスクトップパス取得 Dim MyWSH As Object Set MyWSH = CreateObject("WScript.Shell") GetDeskTopPath = MyWSH.SpecialFolders("Desktop") Set MyWSH = Nothing End Function Function GetUserName() 'ユーザーネーム取得 Dim WshNetworkObject As Object Set WshNetworkObject = CreateObject("WScript.Network") GetUserName = WshNetworkObject.UserName Set WshNetworkObject = Nothing End Function Function GetComputerName() 'コンピューターネーム取得 Dim WshNetworkObject As Object Set WshNetworkObject = CreateObject("WScript.Network") GetComputerName = WshNetworkObject.ComputerName Set WshNetworkObject = Nothing End Function Function SelectFold() As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダー選択" If .Show = -1 Then SelectFold = .SelectedItems(1) Else 'キャンセルボタンがクリックされた SelectFold = "CANCEL" End If End With End Function Function SelectFile() As String With Application.FileDialog(msoFileDialogFilePicker) .Title = "ファイル選択" If .Show = -1 Then SelectFile = .SelectedItems(1) Else 'キャンセルボタンがクリックされた SelectFile = "CANCEL" End If End With End Function
【2つのシートの内容を比較】【エクセル2013,VBA】
複数人で同一ファイルに書き込みをするような作業の際に、作業前のシートと作業後のシートを比較し、どこが修正されたかを確認したくなる場合があります。中には適当なひとやエクセルが苦手なひともいたりするため、気がつかずに違うセルの内容を消したり上書きしたり等のミスが生じることがあります。
比較の対象は「値と数式」です。数式は見た目にはわからなくとも、セルの削除などでおかしなことになるときがあります。書式も比較できるようにしたかったのですが、長くなるので断念しました。
内容
Step0.比較したい2つのシートは同一ブック内にあることが前提。
Step1.比較したい1枚目のシートの比較したい範囲を指定する。
Step2.比較したい2枚目のシートの名前を入力する。
Step3,4.比較作業が行われる。結果は追加されたシートに出力される。（青塗りだと変化なし。赤塗りだと値または数式が異なる。表示されている値は比較シート1の値。）
以下コード
=========================================================
Sub シート比較()
Dim SN1 As String, SN2 As String, SN As String, buf As Range, TCell As Range
'Step1:比較したいシート(1枚目）の比較したい範囲を選択
Set buf = Application.InputBox(prompt:="比較したいシート(1枚目）の範囲を選択してください）", Type:=8)
SN1 = buf.Parent.Name
'Step2:比較したいシート(2枚目）の名前を入力。デフォルト値は2枚目のシート
SN2 = InputBox("比較したいシート(2枚目）の名前を入力", "", Sheets(2).Name)
'Step3:比結果の記入用シートの追加
Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ActiveSheet.Name
'Step4:指定した各セル内容を比較していき、結果シートに記入する。
For Each TCell In buf
'結果シートの対応するセルに比較シート1の数式なければ値を記入していく（書式は関係なし）
Sheets(SN).Range(TCell.Address).Formula = TCell.Formula
'比較シート1と2の数式なければ値を比較し異なる場合には結果シートの対応するセルを赤塗りにしていく。同一であれば青塗り。
If TCell.Formula <> Sheets(SN2).Range(TCell.Address).Formula Then
Sheets(SN).Range(TCell.Address).Interior.Color = 255
Else
Sheets(SN).Range(TCell.Address).Interior.Color = 15773696
End If
Next
End Sub
【複数ブック、アンケート、集計】【エクセル2013,VBA】
アンケートをエクセルで作成し、とりまとめ集計するためののコード。
なるべく汎用的に利用できるように、集計範囲をダイアログボックスで指定できるようにしています。
前提としては
・集計するブックの構成（回答の場所）は全て同じアドレスのセル
・アンケート結果は各ブックの1枚目のシートに記載する
・アンケートのブックは複数指定可
==================================
Sub アンケート集計()
Dim i As Long, j As Long, k As Long, GyoN As Long, tst As String, CellA As String, SN As String
Dim buf As Range, TCell As Range, arr1() As String
Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name
'Step1:集計するセルの指定を行う
With Application.FileDialog(msoFileDialogOpen)
.Title = "まずは集計するセルを指定します。" & Chr(13) & "どれでもよいので集計したいファイルをひとつ開いてください。"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Show
Workbooks.Open Filename:=.SelectedItems(1)
tst = ActiveWorkbook.Name
Set buf = Application.InputBox(prompt:="集計したいセルを選択してください（+ctrで複数選択可）", Type:=8)
ReDim arr1(1 To buf.Cells.Count) As String
i = 1
'セルのアドレスを配列に格納と同時にアドレスを記録
For Each TCell In buf
arr1(i) = TCell.Address
ThisWorkbook.Sheets(SN).Cells(1, i) = arr1(i)
i = i + 1
Next
Workbooks(tst).Close SaveChanges:=False
End With
'Step2:集計
GyoN = 2
With Application.FileDialog(msoFileDialogOpen)
.Title = "集計したいファイルを選択してください（+ctrで複数選択可）"
'複数指定可
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show
'順番にファイルを開き、step1で指定したセルをシートに書き出していく
For i = 1 To .SelectedItems.Count
Workbooks.Open Filename:=.SelectedItems(i)
tst = ActiveWorkbook.Name
For k = 1 To UBound(arr1)
'シートは一枚目のみ利用する。2枚目以降は無視される。
’追加したシートに書き出し
ThisWorkbook.Sheets(SN).Cells(GyoN, k) = Workbooks(tst).Sheets(1).Range(arr1(k))
Next
GyoN = GyoN + 1
Workbooks(tst).Close SaveChanges:=False
Next
End With
End Sub
【複数のブックをひとつのブックにまとめる】【エクセル2013,VBA】
複数のブックをまとめるコード。例えばエクセルで作成した雛形やアンケートをメールで配り記入してもらい、その回答をひとつのブックにまとめたい場合に使用する。
以下コード
==============================================================
Sub シート集計()
Dim i As Long, tst As String, CellA As String
'シート内の特定のセルをシート名にしたい場合はCellAにアドレスを入れる。例：各シートのRange("A1")に名前や固有のIDが入っていてそれをシート名にしたい場合「CellA="A1"」とする。
CellA = ""
With Application.FileDialog(msoFileDialogOpen)
.Title = "統合したいエクセルファイルを選択（+ctr or +shiftで複数選択）"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show
For i = 1 To .SelectedItems.Count
'フルパスからファイル名を取得する。
tst = Dir(.SelectedItems(i))
'選んだブックを順に開く
Workbooks.Open Filename:=.SelectedItems(i)
'シートは「すべて」コピーされる。
Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'CellAが空欄でなければシート名を書き換える
If CellA <> "" Then
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Range(CellA)
End If
'ブックを閉じる。
Workbooks(tst).Close SaveChanges:=False
Next
End With
End Sub
Sub 特定シートの削除()
'おまけ。特定の名前のついているシートを削除する。
Dim SN As String, SC As Long
Application.DisplayAlerts = False
'↓の場合はSheetという文字が含まれるシートを削除
SN = "Sheet"
SC = Sheets.Count
For i = SC To 1 Step -1
If InStr(1, Sheets(i).Name, SN) > 0 Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Sub シート削除All()
'Sheets(1)を除くすべてのシートを削除する。
On Error Resume Next
Dim SN As String, SC As Long
Application.DisplayAlerts = False
SC = Sheets.Count
For i = SC To 1 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
End Sub
【カレンダーの休日を条件付き書式設定で網掛けにする】【エクセル2013,VBA】
チェック表や予約表をエクセルで毎月作成しプリントアウトして使用しているケース多いと思います。毎月手作業で、網掛けにしたり書式を変えたチェック表や予約表の作成を行っている人をみかけると条件付き書式設定が便利ですよと教えてあげたくなるのだけど、その説明が面倒です。加えて、一ヶ月が短い月の表示の対応だとか、会社の休日の対応だとか当然出てくる要望に対処していくと、どんどん説明が面倒になります。なので、しばらくはこちらでファイルをもらって条件付き書式設定してあげるのですが、数が多くなってくると縦・横・分割様々なタイプの表がくるし、時々修正などの要望も入るので、やはり対応が面倒なので自動化をこころみてみました。
ダイアログボックスからの入力だけで、もらったカレンダーの書式設定が簡単にできるコードを書いてみました。
設定の流れ
1.年をリストボックスで表示するセルを選択(初期値A1)
Office TANAKA - Excel VBA Tips[実は奥が深いInputBox]
（inputboxで範囲を指定）
2.月をリストボックスで表示するセルを選択(初期値B1)
別のシートでも可（複数シートの表示月を連動させたい場合はどこか一箇所をしていすればよい）
3.開始日を入力（初期値1)
16日スタートなども可。表が分割されているようなケースに使う。
4.休日リスト（土日以外の休日。祝日含む）を別シートに用意し、その範囲を指定する（なくても可）。
祝日リストはネットにころがっているので入手し会社の休日があればそれに付け加える。
5.条件付き書式設定したい範囲を指定する。
6.表の方向を指定する（縦or横）
選択した方向に応じ、1行or1列目に日付を表示する数式がセルに入力される。
最初のセルの数式は「=Date(年,月,開始日)」のシリアル値とし、
Range(XXX).NumberFormatLocal = "d""(""aaa"")"とすることで日にちと曜日のみを表示する。
DATE関数の使い方 初心者のエクセル(Excel)学習・入門
6.5 文字の表示形式に関する書式設定 - Excel VBA Tips
1行or1列目の数式を以下のように設定
「=IF(INDIRECT(""R[-1]C"",FALSE)="""","""",IF(DAY(INDIRECT(""R[-1]C"",FALSE)+1)=1,"""",INDIRECT(""R[-1]C"",FALSE)+1))」
相対位置を参照する～ExcelでのINDIRECTのすすめ～：システム開発メモ：So-netブログ
選択された範囲に条件付き書式が設定される。
土曜日→青の網掛け
日曜日、休日→赤の網掛
テーマカラーでセルの網かけに色を付ける - PatternThemeColorとPatternTintAndShadeプロパティ - Excel VBA Tips
Excel(エクセル)基本講座：条件付き書式で土日に色を付ける
参考
エクセルExcel大事典 VBAマクロ 日付関数 DateAdd DateDiff DatePart DateSerial Timer
=============================================================
Sub 書式設定()
On Error GoTo ELH
Dim YCell As String, Mcell As String, YList As String, buf As Range, StartC As String, StartR As Long, StartD As Long, i As Long, RCType As String, tst As String, Arr(1 To 4) As Variant
'初期設定値(繰り返し同じ範囲を指定するなら、ここを書き換えておく）
Arr(1) = "$A$1" '年を表示するセル
Arr(2) = "$B$1" '月を表示するセル
Arr(3) = "" '休日リスト範囲例：Sheet1!$A1:$A$100
Arr(4) = "$B$5:$F$34" '条件付書式を設定する範囲
Set buf = Application.InputBox(PROMPT:="年を表示するセルを選択", Type:=8, Default:=Arr(1)) '年を表示するセルを選択
YCell = buf.Worksheet.Name & "!" & buf.Address
buf(1).Select
buf(1) = Year(Date) '初期値＝今年
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Year(Date) & "," & Year(Date) + 1 & "," & Year(Date) + 2 '3年分
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
Set buf = Application.InputBox(PROMPT:="月を表示するセルを選択", Type:=8, Default:=Arr(2)) '月を表示するセルを選択
Mcell = buf.Worksheet.Name & "!" & buf.Address
buf(1).Select
buf(1) = Month(Date) '初期値＝今月
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="1,2,3,4,5,6,7,8,9,10,11,12"
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
StartD = InputBox("カレンダーの開始日を入力", "入力", 1) '開始日を入力
If MsgBox("休日リストを使用しますか？", vbYesNo) = vbYes Then '休日リストの設定。リストはシリアル値で。休日を追加する予定なら広めに指定しておけばよい
Set buf = Application.InputBox(PROMPT:="休日リストが表示されている範囲を選択", Type:=8, Default:=Arr(3))
YList = buf.Worksheet.Name & "!" & buf.Address
Else
YList = ""
End If
Set buf = Application.InputBox(PROMPT:="条件付書式を設定したい範囲を選択", Type:=8, Default:=Arr(4)) '条件付書式を設定したい範囲を選択
Sheets(buf.Worksheet.Name).Select
buf.Select
StartC = Mid(buf(1).Address, 2, InStr(2, buf(1).Address, "$") - 2)
StartR = buf(1).Row
'最初のセルに年と月と開始日からシリアル値を返す数式を入力。表示は日付と曜日のみ。
buf(1) = "=Date(" & YCell & "," & Mcell & "," & StartD & ")"
buf(1).NumberFormatLocal = "d""(""aaa"")"""
RCType = MsgBox("日付の記載方向。" & Chr(13) & "縦方向なら→はい。横方向なら→いいえ。", vbYesNo)
If RCType = 7 Then '横の場合
tst1 = ""
tst2 = "$"
RangeST = tst1 & StartC & tst2 & StartR
'1行目に日付の表示。シリアル値。表示は日付と曜日のみ。
Range(Cells(buf(1).Row, buf(1).Column + 1), Cells(buf(1).Row, buf(buf.Count).Column)) = "=IF(INDIRECT(""RC[-1]"",FALSE)="""","""",IF(DAY(INDIRECT(""RC[-1]"",FALSE)+1)=1,"""",INDIRECT(""RC[-1]"",FALSE)+1))"
Range(Cells(buf(1).Row, buf(1).Column + 1), Cells(buf(1).Row, buf(buf.Count).Column)).NumberFormatLocal = "d""(""aaa"")"""
Else '縦の場合
tst1 = "$"
tst2 = ""
RangeST = tst1 & StartC & tst2 & StartR
'1列目に日付の表示。シリアル値。表示は日付と曜日のみ。
Range(Cells(buf(1).Row + 1, buf(1).Column), Cells(buf(buf.Count).Row, buf(1).Column)) = "=IF(INDIRECT(""R[-1]C"",FALSE)="""","""",IF(DAY(INDIRECT(""R[-1]C"",FALSE)+1)=1,"""",INDIRECT(""R[-1]C"",FALSE)+1))"
Range(Cells(buf(1).Row + 1, buf(1).Column), Cells(buf(buf.Count).Row, buf(1).Column)).NumberFormatLocal = "d""(""aaa"")"""
End If
tst = "=Weekday(" & RangeST & ")=1"
Call SelectionFormat1(255, tst) '日曜日の条件付書式設定。
tst = "=Weekday(" & RangeST & ")=7"
Call SelectionFormat1(15773696, tst) '土曜日の条件付書式設定
If YList <> "" Then '休日リストを使用する場合
tst = "=COUNTIF(" & YList & "," & RangeST & ")>0" 'countifで休日かどうか判断
Call SelectionFormat1(255, tst) '休日の条件付書式設定
End If
Exit Sub
ELH:
MsgBox "終了です。"
End Sub
Sub SelectionFormat1(ColorNo As Long, tst As String)
'条件付書式設定。網掛けの色(ColorNo)と条件式(tst)を引数としている。
Selection.FormatConditions.Add Type:=xlExpression, Formula1:=tst
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlGray8
.PatternColor = ColorNo
.ColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
【画像内の寸法を測定する】【エクセル2013,VBA】
画像に写し込んだ物差し（大きさがわかっていれば何でも良い）のサイズをもとに画像内の物体の寸法を測定するコード。
最初に
・専用ソフトや携帯アプリでこと足りるならそちらをお勧めします。エクセルでやりたいひと向けです。
・画像の大きさ次第のところもありますが、精度がそこまでよくありません。画像が小さく、表示の拡大を行うと微妙にずれます。
・測定途中でやめると、カーソルが矢印に固定されてしまうので注意してください。
クリック動作の検出
始点と終点をクリックしてその2点の距離を測定したいのだが、クリック動作の検出が必須となる。そのためには主に以下の4つがあるそうです。
1. GetAsyncKeyState API
2. GetMessage API
3. サブクラス化
4. マウスの低レベルフック(グローバルフック)
シート上でマウスイベントを検出する方法 | ヴィーバ VeaBa! Excel VBA Tips
1と2がお手軽だがループ処理が必要なため負荷がかかり、カーソルが青丸（処理中）になってしまったのでボツに（ピンポイントで指定できない）。3,4は難しそうなので回避（4はしっかり理解していないと危険とのコメントも）。
つぎにワークシートファンクションでできないかとも考えたが、画像上だとクリック動作の検出ができなかったのでボツ。
そこで、小手先な感じもするがカーソル位置を返すコードを作成し、画像にいわゆるマクロの登録をすることで、クリック動作の検出と画像上のカーソル位置取得を行うことにした。
以下コードの概要
1.ダイアログボックスから画像ファイルを選択する。
2.画像がシートに読み込まれる。画像にカーソルの位置を返すマクロが登録される。
3.画像上のどこかをクリックすると、カーソルが指の形から矢印に変わる。
4.始点をクリック。
5.終点をクリック。始点から終点まで線が引かれ、線の長さがカラムB、Cに出力されていく(Bはピクセル、Cは物差しの長さをもとに計算された値）。線の左上には通し番号を表示。
以下3〜6を繰り返すと複数回、寸法測定が可能。1回目は基準となる物差しの始点と終点を選択し、物差しのサイズを入力すると以降は物差しのサイズをもとに長さが出力される。
例：将棋盤の枡目を物差しとして駒の寸法を測定
0と1は枡目=3cm
=======================================================
以下コード
Dim state As Long, PosiPix(1 To 2, 1 To 2) As Long
Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
CPosix As Long
Cposiy As Long
End Type
'メインコード
Sub 寸法測定開始()
ActiveSheet.Pictures.Insert(File選択("画像を選択してください。")).Select
'画像の位置指定
Selection.ShapeRange.Left = 200
Selection.ShapeRange.Top = 10
'画像にマクロの登録を行う（＝クリックされると寸法測定が動作する）
Selection.OnAction = "寸法測定"
Application.Cursor = xlDefault
state = 1
End Sub
'寸法を測定するコード
Sub 寸法測定()
'1回目のクリック→カーソルを指から矢印に変える
'2回目のクリック→開始点を記録
'3回目のクリック→開始点と終了点に破線をひき距離を書き出す
Dim i As Long
Select Case state 'stateにより何回目のクリックか判別
Case 2 '2回目のクリックなら
'開始点の座標を記憶
PosiPix(1, 1) = GCPPixX
PosiPix(1, 2) = GCPPixY
state = 3
Case 3 '3回目のクリックなら
'終了点の座標を記憶
PosiPix(2, 1) = GCPPixX
PosiPix(2, 2) = GCPPixY
'開始点と終了点に破線をひく
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, PosiPix(1, 1), PosiPix(1, 2), PosiPix(2, 1), PosiPix(2, 2)). _
Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.DashStyle = msoLineSysDot
.Weight = 0.5
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
'結果の書き込み位置の確認。3行目以降の空欄に書き込む。
For i = 3 To 102
If Cells(i, 1) = "" Then
Exit For
End If
Next
'上記破線の左上に通し番号のラベルをつける
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, PosiPix(1, 1) - 5, PosiPix(1, 2), 25, 20).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = i - 3
Selection.ShapeRange.IncrementTop -10
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 6
'通し番号
Cells(i, 1) = i - 3
'一回目の場合のみ、画像内のものさしを設定（定規、10円玉、たばこetc,なんでもいい）
If i = 3 Then
'ものさしの幅を入力（単位はない）
Cells(3, 3) = InputBox("Sizeを入力", "入力", "1")
End If
'ピクセル単位での2点間の距離をB列に記入
Cells(i, 2) = Sqr*1 ^ 2 + (PosiPix(1, 2) - PosiPix(2, 2)) ^ 2)
'ものさしの長さをもとに計算した2点間の距離をＣ列に記入
Cells(i, 3) = Cells(i, 2) / Cells(3, 2) * Cells(3, 3)
'初期状態にもどす。
Application.Cursor = xlDefault
state = 1
Case Else '1回目のクリック
state = 2
Application.Cursor = xlNorthwestArrow 'カーソルを指から矢印に変え
End Select
End Sub
Function GCPPixX() As Single
'カーソルのエクセル内でのX座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI
GetCursorPos Pos
GCPPixX = (Pos.CPosix - ActiveWindow.PointsToScreenPixelsX(0)) / ActiveWindow.Zoom * 100 / 96 * 72
End Function
Function GCPPixY() As Single
'カーソルのエクセル内でのY座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI
GetCursorPos Pos
GCPPixY = (Pos.Cposiy - ActiveWindow.PointsToScreenPixelsY(0)) / ActiveWindow.Zoom * 100 / 96 * 72
End Function
Function File選択(titlestr As String) As String
'ダイアログでファイルを選択し、選択されたファイルのパスを返すファンクション。
If titlestr = "" Then
titlestr = "ファイル選択"
End If
With Application.FileDialog(msoFileDialogFilePicker)
.Title = titlestr
If .Show = -1 Then 'アクションボタンがクリックされた
File選択 = .SelectedItems(1)
Else 'キャンセルボタンがクリックされた
File選択 = "CANCEL"
End If
End With
End Function
*1:PosiPix(1, 1) - PosiPix(2, 1
【シート上の画像をファイルとして保存する】【エクセル2013,VBA】
VBAを使わないでシート上の画像をファイルとして保存する方法
Excel シートに貼り付けた画像をファイルとして保存するには
VBAを使ってシート上の画像をファイルとして保存する方法
下に記したやり方だと画質が落ちる気がするので、上記の方法を使えるなら上記の方法がよい気がする。
画像をいきなりファイルとして保存することはできない様子。だがグラフであればエクスポートにより画像として保存するメソッドがあるのでこれを利用する。つまりは空のグラフをつくり、その中に画像を表示しエクスポートすることでシート上の画像をファイルとして保存できる。
Excel/VBAクリニック，今月の診断 - 第37回 グラフを画像ファイルに保存する：ITpro
以下シート上の全画像をファイルとして保存するコード。ファイルはデスクトップにオブジェクト名で保存される。
============================================================
Sub 保存()
'ワークシートの全オブジェクトをループ
For Each tobj In ActiveSheet.Shapes
If tobj.Type = 13 Then'オブジェクトが画像ならType=13となる。
tobj.CopyPicture
Fname = tobj.Name'オブジェクトの名前を取得
ACWidth = tobj.Width'オブジェクトのサイズを取得（高さ）
ACHeight = tobj.Height'オブジェクトのサイズを取得（高さ）
'オブジェクトとほぼ同サイズの空のグラフを一時的に作る
Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
TCht.Paste’グラフに画像をペーストする。
’エクスポート先はデスクトップ。ファイル名はオブジェクト名。タイプはJPG（書き換えればpng等でもいける。）
TCht.Export Filename:=myDeskTopPath & Fname & ".jpg", filtername:="JPG"
TCht.Parent.Delete’グラフを削除する。
End If
Next
End Sub
Function myDeskTopPath()
' デスクトップパスの取得
Dim MyWSH As Object
Set MyWSH = CreateObject("WScript.Shell")
myDeskTopPath = MyWSH.SpecialFolders("Desktop")
Set MyWSH = Nothing
End Function
