項目

最近使用したファイルの一覧を操作する

内容説明

[ファイル]メニュ−に表示される最近使用したファイルの一覧を操作するにはRecentFilesプロパティを用います。

'最近使用したファイル一覧の最大ファイル数を取得または設定。0〜9までの値が使用可
Application.RecentFiles.Maximum = 5 '最近使用したファイル数を5に設定
Application.RecentFiles.Maximum = 0 '最近使用したファイルを表示しない
'最近使用したファイル一覧にファイルを追加
RecentFiles.Add "c:\ddd\eee.xls"  '最近使用したファイルに"c:\ddd\eee.xls"を追加

Application.RecentFiles.Count     '[ファイル]メニュ−に表示されているファイル数　
Application.RecentFiles(1).Name   '最近使用したファイル一覧の1番目の名前
Application.RecentFiles(2).Delete '最近使ったファイルの一覧の2番目のファイルを削除
Application.RecentFiles(2).Open   '最近使ったファイルの一覧の2番目のファイルを開く　

項目

画面設定の各種命令メモ

内容説明

画面設定を仕上げる高度な命令をまとめて見ました。

'画面状態を設定する
Application.ScreenUpdating = False '画面の更新を行わない
Application.Calculation = xlManual '計算方法を手動にして再計算を行わない
Application.EnableEvents = False   'イベント発生を中止する
Application.DisplayAlerts = False  'ユーザーに入力を促すメッセージを表示させない
Application.Interactive = False    'キーボードやマウスからの入力を受け付けない
With ActiveWindow
  .DisplayGridlines = False '枠線を非表示
  .DisplayHeadings = False '行列番号を非表示
End With
Columns("G:IV").EntireColumn.Hidden = True      '列を非表示
Rows("9:" & Rows.Count).EntireRow.Hidden = True '行を非表示
Worksheets("aaa").ScrollArea = "b3:d35"             'スクロール可能な領域
Worksheets("aaa").EnableSelection = xlUnlockedCells 'LockedプロパティがFalseのセルのみ選択可
'注)ScrollAreaプロパティ及びEnableSelectionプロパティはbookに保存されないので
'   Workbook_OpenやWorkbook_SheetActivateイベント等で起動時に設定する必要があります。
Sheets("tmp").Visible = xlVeryHidden 'False    'シートの非表示。メニューでは再表示出来ない
ActiveSheet.Protect UserInterfaceOnly:=True    'セルの保護。マクロでは変更可
ActiveWorkbook.Protect UserInterfaceOnly:=True 'ブックの保護。マクロでは変更可
ThisWorkbook.Protect Windows:=True 'ブックウィンドウの保護。ブックウィンドウの移動,サイズ変更,表示と非表示の切り替えなどができないようにします
                                   'ブックの×ボタン等が消えます

'画面状態設定の解除
Application.ScreenUpdating = True '画面の更新を行う
Application.Calculation = xlAutomatic '計算方法を自動にして再計算を行う
Application.EnableEvents = True   'イベントの発生をさせる(元に戻す)
Application.DisplayAlerts = True  'ユーザーに入力を促すメッセージを表示させる(元に戻す)
Application.Interactive = True    'キーボードやマウスからの入力を受け付ける(元に戻す)
With ActiveWindow
  .DisplayGridlines = True '枠線を表示
  .DisplayHeadings = True  '行列番号を表示
End With
Columns("G:IV").EntireColumn.Hidden = False      '列を表示
Rows("9:" & Rows.Count).EntireRow.Hidden = False '行を表示
Worksheets("aaa").ScrollArea = ""                   'スクロール可能な領域
Worksheets("aaa").EnableSelection = xlNoRestrictions '全てのセルの選択可
Sheets("tmp").Visible = False    'ｼ-ﾄの表示
ActiveWorkbook.Unprotect 'ｾﾙの保護解除
ActiveSheet.Unprotect    'ﾌﾞｯｸの保護解除
ThisWorkbook.Protect Windows:=False 'ブックウィンドウの解除。ブックウィンドウの移動,サイズ変更,表示と非表示の切り替えなどができます
                                    'ブックの×ボタン等が表示されます

項目

使われているセル範囲を取得する

内容説明

使われているセル範囲や最終行列等を求める方法をまとめてみました。

'ワークシートで使われているセル範囲
ActiveSheet.UsedRange '.Address
ActiveSheet.UsedRange.Row           '使われているセルの始めの行
ActiveSheet.UsedRange.Rows.Count 　 '使われているセルの行数
ActiveSheet.UsedRange.Column        '使われているセルの始めの列
ActiveSheet.UsedRange.Columns.Count '使われているセルの列数

'最終行の取得をする
Range("A1").End(xlDown).Row          'a列の最終行 空白行の上まで
Range("a" & Rows.Count).End(xlUp).Row'a列の最終行

'最終行列取得その2
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '指定条件のセルを返す
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column

SpecialCellsメソッド  指定された条件を満たしているRangeオブジェクトを返します
  構文 expression.SpecialCells(Type, Value)
  Type値              意味
  xlCellTypeNotes	コメントが含まれているセル
  xlCellTypeConstants	定数が含まれているセル
  xlCellTypeFormulas	数式が含まれているセル
  xlCellTypeBlanks	空の文字列
  xlCellTypeLastCell	使われたセル範囲内の最後のセル
  xlCellTypeVisible	すべての可視セル

関連1)画面に表示されているワークシートの範囲
VisibleRangeプロパティ
指定したウィンドウ内に表示されているセル範囲 (Rangeオブジェクト)を返します。
　Debug.Print ActiveWindow.VisibleRange.Address
  '左上隅のセル
　Debug.Print  ActiveWindow.VisibleRange(1).Address
  '右下隅のセル
  Debug.Print ActiveWindow.VisibleRange(ActiveWindow.VisibleRange.Count).Address

関連2)列番号から対応する文字列を得る
列(Column)列番号1〜256を列番号を表す文字列"A"〜"IV" を得る数式です。
'cl=列番号1〜256
=IIf(cl > 26, Chr(Asc("@") + cl \ 26), "") & Chr(Asc("@") + cl Mod 26)

項目

指定されたセル範囲の中から指定値を全て高速に検索する

内容説明

指定されたセル範囲から、指定値を全て検索するkGetRangeF関数を示します。
Findメソッドを用い高速に検索します。結果をRangeオブジェクトで返しますのでいかようにも後処理が可能です。

'kGetRangeF関数  指定されたセル範囲の中から指定値を全て高速に検索する
'引数　 wh：検索する値(数値or文字列)
'  　　 fr：検索範囲(Rangeオブジェクト)
'戻り値 見つかった全てのセル(Rangeオブジェクト)
'　　　 1つも検索されなかった場合はNothingを返す
Function kGetRangeF(wh, fr As Range) As Range
  Dim fa$ 'firstAddress
  Dim rg As Range
  Set rg = fr.Find(What:=wh, LookAt:=xlWhole) ', MatchCase:=True)
  If rg Is Nothing Then Exit Function
  fa = rg.Address '始めに検索されたアドレスを保存
  Set kGetRangeF = rg
  Do
    Set rg = fr.FindNext(rg)
    If rg.Address = fa Then Exit Do '検索が一巡したら終了
    Set kGetRangeF = Union(kGetRangeF, rg)
  Loop
End Function

'kGetRangeF関数の使用例
Sub test_kGetRangeF() 
  Dim fr As Range '検索する範囲
  Dim wh '検索値
  Dim rg As Range, r1 As Range
  Set fr = ActiveSheet.UsedRange '検索範囲
  wh = "AAA" '検索する値
  Set rg = kGetRangeF(wh, fr) '検索
  If rg Is Nothing Then Exit Sub
  'rg.Select '検索されたセルをSelect
  For Each r1 In rg
    Debug.Print r1.Address '検索されたアドレスをDebug.Print
    'Debug.Print r1.Offset(, 1)
  Next
  Debug.Print wh & "は" & rg.Count & "個見つかりました"
End Sub

項目

Bookを開かないでセル値(デ−タ)を取得する

内容説明

他ブックをデ−タベ−スとして使いその値を取得したい場合、通常はブックを開いてセル値をコピ−して取得する必要があります。
そのブックは値を取得するだけなので、出来れば開かず済ませたいですね。その手段を提供するkGetDatCp関数を示します 。(注:内部処理では当然Openして処理されます)

'kGetDatCp関数  Bookを開かないでセル値(デ−タ)を取得する
'引数
'コピ−先(Destination)
'　des：セル範囲(Range) 例 Set des = ActiveSheet.Range("a1:e10")
'元デ−タ(Source)
'　sur：フルファイル名　 例 "B:\xxx\zzz\Book2.xls"、"\\server\aaa\bbb.xls"
'　st ：シ−ト名　　　　 例 "Sheet1"
'　adr：セル左上アドレス 例 "a1"
'戻り値 0:成功 1:元ファイル又はシ−トが無い 2:コピ−先Book又はシ−トが無い
Function kGetDatCp(ByVal des As Range, ByVal sur$, ByVal st$, ByVal adr$) As Long
  Dim fol$, bk$
  bk = Dir(sur)
  If bk = "" Then kGetDatCp = 1: Exit Function '元ファイルが無い
  'fol = Left(sur, InStr(sur, bk) - 1)
  fol = Left(sur, InStrRev(sur, "\"))
  On Error Resume Next
  With des
    If Err Then kGetDatCp = 2: Exit Function
    .Formula = "=IF('" & fol & "[" & bk & "]" & st & "'!" & adr & "="""","""",'" & fol & "[" & bk & "]" & st & "'!" & adr & ")"
    If Err Then kGetDatCp = 2: Exit Function '元シ−トが無い
    .Value = .Value
  End With
End Function

'kGetDatCp関数の使用例
Sub test_kGetDatCp()
  Dim sur$, st$, adr$, des As Range, rt&
  'Source
  sur = "B:\My Documents\Book2.xls"
  st = "Sheet1"
  adr = "a1"
  'Destination
  Set des = ActiveSheet.Range("d1:f10")
  rt = kGetDatCp(des, sur, st, adr)
  MsgBox IIf(rt = 0, "完了", "Error " & rt)
End Sub

項目

[入力規則]-[リスト]ですでに選択済みのリスト項目を選択出来ないようにする

内容説明

複数のセル[入力規則]-[リスト]を設定し、同一の[元値]を用いる場合に、いずれかのセルで選択済みのリスト項目は選択出来ないようにする方法です。
実現手段はリスト[元値]の値を、選択済み項目を省いて再設定しています。汎用的に利用出来るkValidationModify関数を示します。

Worksheet_Change及びWorksheet_SelectionChangeイベントを下記例のように記述して下さい。 Worksheet_SelectionChangeイベントに記述するkValidationModify関数の引数
Range("b2:c2,d4,a1") '[入力規則]-[リスト]を使用しているセル
Range("g2:g8") '[リスト]-[元の値]のセル
は、実状に合わせ設定します。

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  kValidationModify Target, Range("b2:c2,d4,a1"), Range("g2:g8")
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  'Range("b2:c2,d4,a1") '[入力規則]-[リスト]を使用しているセル
  'Range("g2:g8")       '[リスト]-[元の値]のセル
  kValidationModify Target, Range("b2:c2,d4,a1"), Range("g2:g8")
End Sub

'[入力規則]-[リスト]ですでに選択済みのリスト項目を省き選択出来ないようにする
'引数 rg1 :[入力規則]-[リスト]を使用しているセル 例:Range("b2:c2,d4")
'     rg2 :[リスト]-[元の値]のセル 例:Range("g2:g8")
Sub kValidationModify(ByVal Target As Range, rg1 As Range, rg2 As Range)
  Dim rg As Range, ii&, ar, cc$, flg As Boolean
  If Intersect(Target, rg1) Is Nothing Then Exit Sub
  On Error Resume Next '[入力規則]-[リスト]が設定されていない場合はexit
  If Target.Validation.Type <> xlValidateList Then Exit Sub
  If Err Then Exit Sub
  On Error GoTo 0
  ReDim ar(1 To rg2.Count)
  For ii = 1 To UBound(ar): ar(ii) = rg2(ii): Next 'リスト元値を配列へ代入
  For Each rg In rg1
    ii = Application.Match(rg, ar, 0)
    If VarType(ii) <> vbError Then ar(ii) = ""
  Next
  For ii = 1 To UBound(ar) 'リスト元値の文字列を作成
    If ar(ii) <> "" Then cc = cc & IIf(cc = "", "", ",") & ar(ii)
  Next
  If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect: flg = True
  Target.Validation.Modify Formula1:=IIf(cc = "", " ", cc) 'リスト元値を設定
  If flg Then ActiveSheet.Protect UserInterfaceOnly:=True
End Sub

項目

散布図の近似曲線で式の係数を得る

内容説明

散布図等で近似曲線を描いている場合に近似式の係数を得る方法です。
近似式の係数を得るkTrendCoe関数と使用例を示します。
例えば2次多項式が y = 0.245x2 - 0.49x + 25.4 の場合、
aa(0)=0.245,aa(1)=-0.49,aa(2)=25.4,aa(3)=r2乗値
となります。(aaはkTrendCoe関数の戻り値)

'■kTrendCoe関数 散布図近似曲線式の係数を得る
'引数tl 目的の近似曲線
'    例 ActiveSheet.ChartObjects("グラフ 1").Chart.SeriesCollection(1).Trendlines(1)
'　　   ActiveChart.SeriesCollection(1).Trendlines(1)
'戻り値 近似式の係数が配列で戻る aa(0)〜aa(UBound(aa))
Function kTrendCoe(tl As Trendline) As Variant
  Dim ss$, nf$, ii&, aa, de As Boolean, dr As Boolean
  With tl
    '近似曲線の種類 xlExponential,xlLinear,xlLogarithmic,xlMovingAvg,xlPolynomial,xlPowerのいずれか
    If .Type = xlMovingAvg Then Exit Function '移動平均
    de = .DisplayEquation: dr = .DisplayRSquared
    .DisplayEquation = True: .DisplayRSquared = True
    nf = .DataLabel.NumberFormat
    .DataLabel.NumberFormat = "0.00000000000000"
    ss = .DataLabel.Text
    .DataLabel.NumberFormat = nf
    .DisplayRSquared = dr: .DisplayEquation = de
    If .Type = xlPower Then ss = Replace(ss, "x", " ")
    If .Type = xlExponential Then ss = Replace(ss, "e", " ")
  End With
  ss = Mid(ss, 5)
  ss = Replace(ss, vbLf & "R2 =", "")
  ss = Replace(ss, "- ", "-")
  ss = Replace(ss, "+ ", "")
  aa = Split(ss)
  For ii = 0 To UBound(aa)
    aa(ii) = Val(aa(ii))
  Next
  kTrendCoe = aa
End Function
'Excel2000以降は以下のSplit関数及びReplace関数は不要(削除可)
#If VBA6 Then
#Else
'Excel97用Split関数
Function Split(expr$, Optional deli$ = " ") As Variant
  Dim ar() As Variant, p1&, p2&, nn&
  p1 = 1
  Do
    p2 = InStr(p1, expr, deli)
    ReDim Preserve ar(0 To nn)
    If p2 = 0 Then ar(nn) = Mid(expr, p1): Exit Do
    ar(nn) = Mid(expr, p1, p2 - p1)
    p1 = p2 + Len(deli): nn = nn + 1
  Loop
  Split = ar
End Function
'Excel97用Replace関数
Function Replace(expr$, fin$, repl$) As String
  Replace = Application.Substitute(expr, fin, repl)
End Function
#End If

'■kTrendCoe関数の使用例
Sub test_kTrendCoe()
  Dim aa, ii&, tl As Trendline
  'データ系列の近似曲線を設定
  Set tl = ActiveChart.SeriesCollection(1).Trendlines(1)
  aa = kTrendCoe(tl)
  '以下は結果の出力例
  Debug.Print
  If tl.DisplayEquation Then Debug.Print tl.DataLabel.Text
  For ii = 0 To UBound(aa)
    Debug.Print aa(ii) & vbTab;
  Next
  Debug.Print
End Sub

注)このkTrendCoe関数は一種の文字列操作のサンプルみたいなものです。 実際に多項式等の近似を行う場合はx,yのセルデータから直接算出(回帰分析)して下さい。

ワークシート上で回帰分析をするには次のワ−クシ−ト関数を用いる事が出来ます。(詳細はヘルプ参照)
LINEST関数：最小二乗法により指定したデータに最もよく当てはまる直線を算出し係数を返す
TREND関数 ：最小二乗法により直線上で指定したx の配列に対するyの近似値を返す
LN関数　　：数値の自然対数を返す

追記1：回帰分析
数式(マクロ)で多項式近似等の回帰分析を行うには ソフトウェア<Our Software> エクセルVBAテクニック集 kVBA3 ユーザー関数編 をご参照下さい。
以下に kVBA3 の回帰分析の機能の一部をコードで紹介します。


'■線形近似 y = ax + b
Sub test_Linest()
  Dim rx As Range, ry As Range, aa
  Set rx = Range("b5:b12") 'x軸データ
  Set ry = Range("c5:c12") 'y軸データ
  If rx.Columns.Count > 1 Or rx.Count <> ry.Count Then Beep: Exit Sub 'データ不正
  aa = Application.LinEst(ry, rx, True, True)
  '以下は結果の出力例
  Debug.Print
  Debug.Print "線形近似 y = ax + b"
  Debug.Print "a="; aa(1, 1), "b="; aa(1, 2)
  Debug.Print "r^2="; aa(3, 1)
End Sub

'■2次方程式近似 y = ax^2 + bx + c
Sub test_2Lstsq()
  Dim rx As Range, ry As Range, aa, xx, ii&
  Set rx = Range("b5:b12") 'x軸データ
  Set ry = Range("c5:c12") 'y軸データ
  If rx.Columns.Count > 1 Or rx.Count <> ry.Count Then Beep: Exit Sub 'データ不正
  xx = rx.Resize(, 2)
  For ii = 1 To UBound(xx)
    xx(ii, 2) = xx(ii, 1) ^ 2
  Next
  aa = Application.LinEst(ry, xx, True, True)
  '以下は結果の出力例
  Debug.Print
  Debug.Print "2次方程式近似 y = ax^2 + bx + c"
  Debug.Print "a="; aa(1, 1), "b="; aa(1, 2), "c="; aa(1, 3)
  Debug.Print "r^2="; aa(3, 1)
End Sub

追記2：関数式のグラフ作成
関数式を与えてグラフを描画するには ソフトウェア<Our Software> エクセルVBAテクニック集 kVBA2をご参照下さい。

項目

グラフや表を図形ファイルとして保存する

内容説明

[挿入]-[グラフ]等で作成したオブジェクトを図形ファイルとして保存するには Exportメソッドを用います。

'jpg形式での保存例
Worksheets("Sheet1").ChartObjects("グラフ 1").Chart.Export "test0.jpg"
'png形式での保存例
ActiveChart.Export "test0.png"
'gif形式での保存例
ActiveSheet.ChartObjects(1).Chart.Export "test0.gif"

特記)グラフィックフィルタについて
Exportメソッドで[アプリケーション定義またはオブジェクト定義のエラーです。]が表示され、"GIFIMP32.FLT"または"JPEGIM32.FLT"が存在しない場合は[グラフィックフィルタ]がインスト−ルされていません。(ファルダは "\Program Files\Common Files\Microsoft Shared\Grphflt")
[コントロールパネル]-[アプリケーションの追加と削除]-[Microsoft Office ??]を実行し、追加インスト−ルで[コンバータおよびフィルタ]-[グラフィックフィルタ]の[jpgファイル(読み込み)]及び[gifファイル(読み込み)]を追加して下さい。
注)Exportメソッドのエラーが解消されない？　
Grphfltフォルダに*.FLTファイルが存在するのにExportメソッドでエラーが解消されない場合、他バージョンのエクセルインストール等で[グラフィックフィルタ]のバージョンが対応しなくなっている可能性があります。
この場合はGrphfltフォルダ内のファイルを削除して、[グラフィックフィルタ]を再インスト−ルして下さい。

応用) 選択オブジェクトや表(セル範囲)を図形ファイルとして保存するkCellExport関数
グラフのExportメソッドを利用して保存した画像は枠の余白が残ってしまうと言う記述をWEBや書籍で見かけますが、そんな事はありません。要はコードの書き方次第です。
APIやWeb保存などを用いず、簡単にシート上のオブジェクトをjpg,png又はgifファイルとして保存するkCellExport関数をご利用下さい。

'kCellExport関数
'選択範囲又は指定したオブジェクト(セル範囲等)を画像ファイル(jpg,png又はgif)として保存
'引数　ff:保存するフルファイル名(拡張子はjpg,png,gif,tif等) 注:同名ファイルがあると上書き
'　　　rg: 画像ファイルにするオブジェクト(セル範囲等。省略値は選択範囲)
Function kCellExport(ByVal ff As String, Optional ByVal rg As Object) As Long
  If rg Is Nothing Then Set rg = Selection
  If TypeOf rg.Parent Is Chart Then Set rg = rg.Parent
  If TypeOf rg Is ChartObject Then Set rg = rg.Chart
  If TypeOf rg Is Chart Then rg.Export ff: Exit Function 'グラフ
  rg.CopyPicture xlScreen, xlBitmap '対象範囲の画像をコピー
  '新しい埋め込みグラフを作成(作業用)
  With ActiveSheet.ChartObjects.Add(rg.Left, rg.Top, rg.Width, rg.Height).Chart
    .ChartArea.Border.LineStyle = 0
    .Paste '作業用グラフに貼りつけ
    .Shapes(1).Left = -.ChartArea.Left
    .Shapes(1).Top = -.ChartArea.Top
    Application.CutCopyMode = False 'コピーモードを解除
    .Export ff 'jpg/png/gif/tif 'ファイルに出力
    .Parent.Delete
  End With
End Function

'kCellExport関数の使用例
Sub test_kCellExport()
  Dim rt&
  '選択オブジェクトを保存
  rt = kCellExport("d:\test000.jpg")
  If rt Then MsgBox "er=" & rt, , "kCellExportのエラー"
  '指定オブジェクトを保存
  rt = kCellExport("d:\test000.gif", ActiveSheet.Range("b2:C4"))
  'rt = kCellExport("d:\test000.gif", ActiveSheet.Shapes("AutoShape 1"))
　'rt = kCellExport("d:\test000.gif", ActiveSheet.ChartObjects("グラフ 1"))
  If rt Then MsgBox "er=" & rt, , "kCellExportのエラー"
End Sub

項目

ワークシートを非表示にする

内容説明

ワークシートを非表示にするには[書式]-[シート]-[表示しない]コマンドで実行出来ます。
再び表示するには[書式]-[シート]-[再表示]コマンドで出来ます。
ところが [書式]-[シート]-[再表示]コマンドでは再表示出来ないマクロの記述があります。 VisibleプロパティにxlVeryHiddenを設定します。

'Sheetを非表示にする例
'ユーザーの操作([書式]-[シート]-[再表示])で表示する事は出来ません
'xlVeryHiddenプロパティにTrueを設定しない限りオブジェクトを表示しません
Sub test1_E97M051()
  Worksheets("Sheet1").Visible = xlVeryHidden 'False
  MsgBox "Sheet1を非表示にしました." & vbCrLf & _
    "[書式]-[ｼｰﾄ]-[再表示]コマンドでは表示する事が出来ません." & vbCrLf & _
    "再表示するにはa_E97M051bを実行して下さい.", , "シートの非表示"
End Sub

'非表示にしたSheetを表示する例
Sub test2_E97M051()
  Worksheets("Sheet1").Visible = True
End Sub

注)ワークシートが1つのみ表示されている状態ではそのワークシートを非表示には出来ません。その場合は[ウィンドウ]-[表示しない]コマンドでBook自体を非表示にします。

項目

Excelタイトルバーの表示を変える

内容説明

Excelウィンドウ及びキュメントウィンドウのタイトルバーに表示される名前を変更するサンプルを示します。


Sub test_E97M051()
  'Excelウィンドウのタイトルバーに表示される名前。名前が省略だと"Microsoft Excel"です。
  Application.Caption = "xxx処理システム"
  'キュメントウィンドウのタイトルバーに表示される名前
  ActiveWindow.Caption = "xxx入力画面"
  MsgBox "Excelタイトルバーの表示を変更しました." & vbCrLf & _
    "[OK]ボタンをクリックすると元に戻ります.", , "xxx処理システム"
  Application.Caption = ""
  ActiveWindow.Caption = ActiveWorkbook.Name
End Sub