TOMBO Excel 2000 (9.0.6926 SP3) VBA-Sample(1)

EXCEL VBA-Sample(1)

●ファイル情報

Sub FileInfo()
'ファイル情報をシートに書き込みます
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("C:\Data\test.xls")
With Sheets("Sheet1")
.Range("A1").Value = f.DateCreated 'ファイル作成日時
.Range("A2").Value = f.DateLastAccessed 'アクセス日
.Range("A3").Value = f.Size / 1024 & " KB (" & f.Size & "Bite)" 'ファイルサイズ
.Range("A4").Value = f.DateLastModified 'ファイル更新日時
End With
'ファイル情報を表示します
s = UCase(f.Name) & vbCrLf
s = s & "ファイルサイズ: " & f.Size / 1024 & " KB (" & f.Size & "Bite)" & vbCrLf
s = s & "作成日時: " & f.DateCreated & vbCrLf
s = s & "最終アクセス日: " & f.DateLastAccessed & vbCrLf
s = s & "最終更新日時: " & f.DateLastModified
MsgBox s, 0, "ファイル情報"
End Sub

＜注＞コード例は、シート1のセルA1～A4にそれぞれのデータを書き込みます。
シート保護している場合は、各セルのロックを解除してください。
＜注＞5行目のファイルのパスとファイル名はご自分の環境に書き換えてください。
＜注＞新規ブックの場合は、一旦保存してから実行してください。

＜参考＞ファイル保存時に自動実行 [ThisWorkbook]

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("C:\Data\test.xls")
If ThisWorkbook.Saved = False Then
With Sheets("Sheet1")
.Range("A1").Value = f.DateCreated 'ファイル作成日時
.Range("A2").Value = f.DateLastAccessed 'アクセス日
.Range("A3").Value = f.Size / 1024 & " KB (" & f.Size & "Bite)" 'ファイルサイズ
.Range("A4").Value = f.DateLastModified 'ファイル更新日時
End With
End If
End Sub

＜注＞既存のブックに対してコードを保存してください。
＜注＞4行目のファイルのパスとファイル名はご自分の環境に書き換えてください。
＜注＞シート１のセルA1～A4のデータは新しいデータに書き換えられます。

●指定ドライブのExcelファイル検索、書き出し(FileName,Size,Date)

Sub myFileSearchALL()
On Error GoTo myFileSearchALL_Err

Dim i As Long
Dim myFound As String
Dim sDrv As String
Dim DefaultSheetNum

' 検索対象となるドライブ名を入力
sDrv = StrConv(InputBox("検索ドライブとフォルダパスを正しく入力してください..." & vbCr & "入力されたサブフォルダも検索します", _
ドライブ名とフォルダ指定, "C:\"), vbNarrow)

If MsgBox("検索フォルダ = " & (sDrv) & vbCr & vbCr & "ファイル検索を実行しますか？", vbYesNo) = vbYes Then

Columns("A:C").ClearContents 'A～C列の旧データをクリアします

' 画面更新を停止
Application.ScreenUpdating = False

DefaultSheetNum = Application.SheetsInNewWorkbook
' タイトル行を作成します
ActiveSheet.Cells(1, 1).Value = "Folder_File_Name"
ActiveSheet.Cells(1, 2).Value = "File_Size"
ActiveSheet.Cells(1, 3).Value = "File_Date"

' ファイル検索を開始
With Application.FileSearch
.NewSearch
.LookIn = sDrv
.SearchSubFolders = True 'サブフォルダも検索する
'.SearchSubFolders = False 'サブフォルダは検索しない

.FileType = msoFileTypeAllFiles '全ファイルを検索する
'.FileType = msoFileTypeOfficeFiles 'Officeファイルを検索
'.FileType = msoFileTypeExcelWorkbooks 'エクセルファイルを検索
'.FileType = msoFileTypeWordDocuments ' ワードファイルを検索

If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
Cells(i + 1, 1).Value = .FoundFiles(i)
Cells(i + 1, 2).Value = FileLen(.FoundFiles(i))
Cells(i + 1, 3).Value = FileDateTime(.FoundFiles(i))
Next i
MsgBox "ファイル検索を終了しました"
ActiveSheet.Cells(1, 1).Value = Now() & " 現在 " & sDrv & " // に " & .FoundFiles.Count & " 個のファイル"
ActiveSheet.Columns("A:C").AutoFit
Else
MsgBox "対象ファイルは見つかりません"
End If
End With

' 画面更新を再開
Application.ScreenUpdating = True
End If
myFileSearchALL_Err:
End Sub

＜注＞ドライブ名とフォルダ指定は使用環境に合わせて書き換えてください。

<参考>Ａ～Ｃ列をクリアする場合のコード例
Range("A:C").Clear 'ABC列をクリア
<参考>シートの全データ全削除する場合のコード例
Cells.Clear 'シートを全クリア

＜参考＞プログラム処理中、画面更新せず高速化
Application.ScreenUpdating = False '---画面更新しない
Application.ScreenUpdating = True '---画面更新する
＜参考＞
ActiveSheet.EnableCalculation = False '---再計算しない
ActiveSheet.EnableCalculation = True '---再計算する

●指定フォルダのファイル名一覧を作成
Sub myFileList() '指定フォルダのファイル一覧を最左シート(Sheet1)に書き出します On Error GoTo ErrorHandler Target = InputBox("フォルダ名を入力", "フォルダ指定", "D:\Documents") Set FS = CreateObject("Scripting.FileSystemObject") Set Fol = FS.GetFolder(Target) Set Fil = Fol.Files ThisWorkbook.Sheets("Sheet1").UsedRange.Delete '見出し ThisWorkbook.Sheets(1).Range("B1") = "ファイル名" ThisWorkbook.Sheets(1).Range("C1") = "ファイル種別" ThisWorkbook.Sheets(1).Range("D1") = "最終更新日" ThisWorkbook.Sheets(1).Range("E1") = "説明" ThisWorkbook.Sheets(1).Range("B1:E1").Interior.Color = RGB(0, 0, 0) ThisWorkbook.Sheets(1).Range("B1:E1").Font.Color = RGB(255, 255, 255) ThisWorkbook.Sheets(1).Range("B1:E1").HorizontalAlignment = xlCenter i = 2 'データ書き出し行 For Each Fx In Fil 'ファイル名 sFile = Fx.Name 'ファイル名の書き出し ThisWorkbook.Sheets(1).Cells(i, 2) = sFile 'B列 'ファイル種別 sFType = Fx.Type '最終更新日時の書き出し ThisWorkbook.Sheets(1).Cells(i, 3) = sFType 'C列 '最終更新日 sLMod = Fx.DateLastModified ThisWorkbook.Sheets(1).Cells(i, 4) = sLMod 'D列 i = i + 1 Next MsgBox "指定フォルダのファイル一覧を書き出しました。" ErrorHandler: End Sub
*フォルダ指定ダイアログの既定フォルダ名は D:\Documents としていますが任意指定が可能です。
＜参考＞ファイル名一覧を作成（2）
Option Explicit Sub myFILENAME() 'C:\Data内のファイル名の一覧をアクティヴシートに作成します Dim myFILENAME As String Const myDir As String = "C:\Data" Application.ScreenUpdating = False Range("A:A").Clear Range("A1").Value = myDir & "/ファイル名一覧 " & Now myFILENAME = Dir("*") While myFILENAME <> vbNullString Cells(Rows.Count, 1).End(xlUp).Offset(1).Value _ = myFILENAME myFILENAME = Dir() Wend Columns(1).AutoFit Application.ScreenUpdating = True End Sub	＜参考＞ '隠しファイルとシステムファイルも表示 myFILENAME = Dir(myDir & "", vbHidden + vbSystem) myFILENAME = Dir(".xls") 'Excelファイルのみ myFILENAME = Dir("*", vbDirectory) 'ファイルとフォルダ
＜注＞ドライブ名とフォルダ指定は使用環境に合わせて書き換えてください。コード例では、C:\Data のすべてのファイルが対象となります。

●セルのファイル名をダブルクリックで開く
Option Explicit Private Sub Worksheet_BeforeDoubleClick _ (ByVal Target As Range, Cancel As Boolean) Const myDir As String = "C:\Data" ' 'セル入力されたファイルのフォルダ名 ChDrive myDir ChDir myDir On Error Resume Next Workbooks.Open Target.Value Cancel = True End Sub	(注)Excelで開くことが可能なファイルのみ Excel ファイル HTMLファイル(html）テキストファイル（txt）
＜参考＞前記 [指定フォルダのファイル名一覧を作成] で書き出されたファイル名をクリックして、そのファイルを開くコード例です。＜参考＞特定のEXCELシートをアクティブにして起動 Dim objEXCEL As Object Set objEXCEL = CreateObject("Excel.Application") objEXCEL.Visible = True objEXCEL.UserControl = True objEXCEL.Workbooks.Open FileName:="Excelブックのフルパス名" objEXCEL.Sheets("表示させたいシート名").Select

●エクセルのメニュー項目一覧 [Module1]

Sub myExcelMENU()
'Excelのメニュー項目一覧をシートに書き出します。

Dim CTRL1 As CommandBarControl
Dim CTRL2 As CommandBarControl
Dim CTRL3 As CommandBarControl

Sheets("Sheet1").Select 'シート１を指定
Columns("A").ClearContents 'A列を一旦クリア
Range("A2").Select 'セルA2以下に書き出しを指定

For Each CTRL1 In CommandBars("Worksheet Menu Bar").Controls
Selection.Value = "[" & Replace(CTRL1.Caption, "&", "") & "]"
If CTRL1.Type = msoControlPopup Then
Selection.Offset(1, 0).Select

For Each CTRL2 In CTRL1.Controls
Selection.Value = "[" & Replace(CTRL1.Caption, "&", "") _
& "] - [" & Replace(Replace(CTRL2.Caption, "&", ""), "...", "") & "]"
If CTRL2.Type = msoControlPopup Then
Selection.Offset(1, 0).Select
For Each CTRL3 In CTRL2.Controls
Selection.Value = "[" & Replace(CTRL1.Caption, "&", "") _
& "] - [" & Replace(Replace(CTRL2.Caption, "&", ""), "...", "") _
& "] - [" & Replace(Replace(CTRL3.Caption, "&", ""), "...", "") & "]"
Selection.Offset(1, 0).Select
Next
Selection.Offset(-1, 0).Select
End If
Selection.Offset(1, 0).Select
Next
End If
Selection.Offset(1, 0).Select
Next
End Sub

＜注＞シート１のA列のデータはクリアされます。必要な場合は新規A列を挿入してから実行してください。
＜参考＞項目を書き出すシートやセルは必要に応じて変更してください。

●ブック内のシート名一覧

Sub myShNAME()
'ブック内のシート名一覧を書き出します

Dim i As Integer

For i = 1 To Sheets.Count
ActiveCell.Offset(i - 1).Value = Sheets(i).Name
Next

End Sub

＜注＞選択されているセル（アクティブセル）以下に書き出します。
シート名にはグラフシートも含まれます。

●ファイルの上書き保存時、更新日時をシートに書き込む [ThisWorkbook]

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'書き換えがあった場合に上書き保存すると
'現在時刻をSheet1のC1セルに書き込みます
If ThisWorkbook.Saved = False Then
Sheets("sheet1").Range("C1").Formula = Now
End If
End Sub

＜注＞シート1のセルC1は書式 yy/m/d hh:mm:ss で時刻も取得します。
＜注＞シート保護状態では実行エラー1004 が発生するため、対象セルのロックを解除してください。

＜参考＞
' '100分の1秒まで取得したい場合の追加マクロ

' If ThisWorkbook.Saved = False Then
' Sheets("Sheet1").Range("G1").Formula = Date
' Sheets("Sheet1").Range("G2").Formula = Timer() / 86400
' Sheets("Sheet1").Range("C1").NumberFormatLocal = "yy/m/d hh:mm:ss.00"
' Sheets("Sheet1").Range("C1").Formula = "=G1+G2"
' End If

'ファイルを開いたときに前回書き換え後、上書き保存した日時をメッセージボックスで表示します

Private Sub Workbook_Open()
MsgBox "このファイルの最終更新日時は " & _
Sheets("Sheet1").Range("C1") & " です"
End Sub

＜参考＞
Msgbox("メッセージ","タイトル") コマンドで、"メッセージ"部分のテキストを２行に分けて表示するには
Msgbox "メッセージ" & vbcr & "メッセージ"

●すべてのブックを一括保存する

Sub SaveAllBooks()
' 複数開かれているブックを一括保存します
Dim aBook As Workbook
For Each aBook In Workbooks: aBook.Save: Next aBook
End Sub

＜参考＞[SHIFT]キーを押しながら、メニューの [ファイル]-[すべて閉じる]
＜参考＞データを保存する場合は、[ファイル]-[作業状態の保存]
上記いずれの操作でも、変更のあった各ブックの保存確認ダイアログが表示されます。
そのため、必ず [はい]/[いいえ]/[キャンセル]に応答する必要があります。

コード例は保存確認ダイアログを表示せず、一度に保存します。
個人用マクロブックか、適当なアドインに保存して利用しましょう。

●ファイルの編集期限を設定する [ThisWorkbook]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'期限日以降のファイル編集を無効にします。
'マクロを無効にすると機能しませんので注意が必要です。
If Now > #2/23/2011 9:00:00 AM# Then '日付時刻を指定
MsgBox "期限が過ぎましたのでファイル内容の変更はできません。"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub

ファイルを開くとき、マクロを無効にすると編集期限設定は無視されます。
コード例はExcelファイル（Book）を編集できる期限を日付指定（４行目）で 2011/2/23 午前9時 と指定しています。
この日時を過ぎるとファイル編集作業が無効になり、メッセージが表示されます。

例えば、４行目を以下のように記述すると、Sheet1のB1セルに記述した日付と比較できます。
If Now > Worksheets("Sheet1").Range("B1").Value Then 'B1セルに期限日を記入の場合

●ファイルオープン時、シートに通し番号を自動的に振る [ThisWorkbook]

Private Sub Workbook_Open()
Sheets("Sheet1").Range("A1").Value = Sheets("Sheet1").Range("A1").Value + 1
End Sub

＜注＞シート1のセルA1に書き込む例です。
最初の値をゼロとしてシートを保存した場合、次回は１となります。

＜参考＞シートを指定して開く

Private Sub Workbook_Open()
Sheets("Sheet1").Activate
Range("A1").Select
End Sub

上記コード例ではシート１のセルA1を指定しています。
（注）シート名Sheet1が無い場合のエラーを回避するには２行目を
Worksheets(1).Activate
と記述すると、シート名に関係なくブックの再左シートを指定出来ます。

＜参考＞ブックを最大化して開く

Private Sub Workbook_Open()
'Bookを最大化して開きます
Application.WindowState = xlMaximized
End Sub

●ウインドウ分割画面で、複数シートのスクロール（行位置）を連動させる [ThisWorkBook]

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim wActSh As Worksheet, wRow
Application.EnableEvents = False
Set wActSh = ActiveSheet
Worksheets(Sh.Name).Activate
wRow = ActiveWindow.ScrollRow
wActSh.Activate
ActiveWindow.ScrollRow = wRow
Application.EnableEvents = True
End Sub

＜参考＞[ウインドウ]-[新しいウインドウを開く] で違うシートを同時に画面表示できます。（Book：1 Book：2）
たとえば、Book：1でSheet1を表示し、Book：2でSheet2を表示した場合、ふたつのシートで同じ行を表示します。

●ウインドウ分割画面で、複数シートのスクロール行列位置を連動させる [ThisWorkBook]

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim wActSh As Worksheet, wRow
Dim wActCh As Worksheet, columns
Application.EnableEvents = False
Set wActSh = ActiveSheet
Set wActCh = ActiveSheet
Worksheets(Sh.Name).Activate
wRow = ActiveWindow.ScrollRow
wActSh.Activate
ActiveWindow.ScrollRow = wRow
Worksheets(Sh.Name).Activate
columns = ActiveWindow.ScrollColumn
wActCh.Activate
ActiveWindow.ScrollColumn = columns
Application.EnableEvents = True
End Sub

＜参考＞[ウインドウ]-[新しいウインドウを開く] で違うシートを同時に画面表示できます。（Book：1 Book：2）
たとえば、Book：1でSheet1を表示し、Book：2でSheet2を表示した場合、ふたつのシートで同じ行列を表示します。

●複数シートを並べてウィンドウ表示

Sub myGAMEN()
ActiveWindow.NewWindow ’新しいウインドウを開く
Windows.Arrange ’すべて画面に表示
End Sub

Arrange引数指定オプション
Windows.Arrange ArrangeStyle:=xlHorizontal '画面の上から下へ縦積み
' Windows.Arrange ArrangeStyle:=xlVertical '画面の左から右へ横並び
' Windows.Arrange ArrangeStyle:=xlTiled 'すべて画面に表示(既定値)
参考：同一シートは水平垂直同期させる場合
Windows.Arrange xlArrangeStyleVertical, ActiveWorkbook:=True, SyncHorizontal:=True, SyncVertical:=True

●ウィンドウを指定サイズに固定 [Sheet1]

Private Sub Worksheet_Activate()
'シート選択時にウインドウサイズを固定します

With ActiveWindow
.WindowState = xlNormal
.Width = 300 'ウィンドウ幅を300に設定
.Height = 200 'ウィンドウの高さを200に設定
.EnableResize = False '閉じるボタンのみ表示
End With
End Sub

Private Sub Worksheet_Deactivate()
'別シート選択時にウインドウサイズ固定を解除します

With ActiveWindow
.WindowState = xlNormal
.Left = 0 'ウィンドウの左端を一番左に設定
.Top = 0 'ウィンドウの上端を一番上に設定
.Height = Application.UsableHeight '高さ最大
.Width = Application.UsableWidth '幅を最大
.EnableResize = True '最小化・最大化・閉じるボタンを表示

End With
End Sub

＜参考＞コードをVBAProject Sheet1 に記入した場合、1枚目(最左シート)のみサイズを固定します。
＜参考＞別のシートを選択した場合は通常のウインドウ表示にします。

Sub mySheetResize()
'アクティブウィンドウのサイズを固定します
'ブックを閉じるまでサイズ変更を許可しません

With ActiveWindow
.WindowState = xlNormal
.Width = 300 'ウィンドウ幅を300に設定
.Height = 200 'ウィンドウの高さを200に設定
.EnableResize = False 'ウィンドウサイズ固定
End With

End Sub

＜参考＞コードを実行すると、すべてのシートは指定サイズに固定され変更できません。
＜注＞ブックを閉じるとサイズ固定は解除されます。

●先頭レコード表示	●画面スクロール
Sub myTOP() '画面の一番上にカーソル移動表示 Dim r As Range, i As Integer Range(Range("A1"), Range("A1").End(xlDown)).Select '項目行指定 Selection.SpecialCells(xlCellTypeVisible).Select i = 0 For Each r In Selection i = i + 1 If i = 2 Then r.Select Exit Sub End If Next r End Sub	Sub mySCROLLTOP() ' 画面の一番上表示 Dim hr As Range Set hr = Range("A1") '左上隅セルを設定 ActiveWindow.ScrollRow = hr.Row '行の一番上にスクロール ActiveWindow.ScrollColumn = hr.Column '列の一番左にスクロール End Sub
＜参考＞オートフィルタで、レコード抽出中でも先頭レコードを表示します。項目行、あるいは先頭行は任意指定してください。（コード例はセルA1としています）

●フィルタの変数（値）をユーザ定義関数で取得するには [Module1]

Public Function GetPat(FilterN As Integer) As String
Application.Volatile
GetPat = ""
On Error Resume Next
GetPat = Mid(ActiveSheet.AutoFilter.Filters(FilterN).Criteria1, 2)
On Error GoTo 0
End Function

＜手順1＞ユーザー定義関数を作成します。（上記コード）
＜手順2＞ワークシートに関数式 =GetPat(1) を入力します。(1) は左からの列数指定です。
＜参考＞オートフィルタでレコード抽出されたとき、その値を取得できます。

●上下左右に、指定分アクティブウィンドウをスクロール

　Sub LargeAndSmallScrollSamp1()
　 With ActiveWindow
　 .LargeScroll Down:=10 '---下方向に10ページスクロール
　 .SmallScroll ToRight:=10 '---右方向に10列スクロール
　End With
　End Sub

Windowオブジェクトを対象に、LargeScrollメソッドでは指定したページ数分だけ、
　SmallScrollメソッドでは指定したセル数分だけ、ウィンドウをスクロールさせます
　LargeScrollメソッドのページは、印刷時のページではなく、ウィンドウに表示されている範囲を1ページとしてカウントします

構文 Object.LargeScroll(Down, Up, ToRight, ToLeft) ページ単位でスクロール
　 Object.SmallScroll(Down, Up, ToRight, ToLeft) セル単位でスクロール
　　設定項目内容
　Object Pane、Windowオブジェクト [省略不可]
　Down 指定しただけ、下方向にスクロール　[省略可能]
　Up 指定しただけ、上方向にスクロール　[省略可能]
　ToRight 指定しただけ、右方向にスクロール　[省略可能]
　ToLeft 指定しただけ、左方向にスクロール　[省略可能]

処理過程を表示させないことで、パフォーマンスの向上をねらいます
ScreenUpdatingプロパティがTrueの場合、プログラムの処理過程が画面に更新されます
Falseの場合、プログラムが終了するか、再びTrueを設定されるまで
画面が更新されません処理速度を向上させたい場合や、画面のちらつきを無くしたいにはFalseを設定してください
終了すると、ScreenUpdatingプロパティは自動的にTrueに戻ります

Trueでシートの再計算を行い、Falseでは行いませんシートに多数の計算式があり、
処理の途中では再計算の必要が無い場合、一旦再計算をさせない方が処理が速くなりますので、
処理速度に問題がある場合などに使うと便利です

EnableCalculationの設定はブックを閉じた後も有効です
再計算をさせないままのシートはトラブルの原因となりがちです
マクロの終了前にEnableCalculationをTrueに戻してください

＜参考＞シートのスクロールエリアを設定する

Sub シートのスクロールエリア設定()
Sheets("Sheet1").ScrollArea = "A10:E20"
End Sub

Sub シートのスクロールエリア解除()
Sheets("Sheet1").ScrollArea = ""
End Sub

＜注＞コード例では、スクロールエリアシート１のA10～E20 を設定しています。
＜注＞エリア以外のセルに移動や画面表示はできません。

●ScrollColumn プロパティの使用例下記のコード例は、列 3 が左端になるように、ウィンドウをスクロールします
Worksheets("Sheet1").Activate ActiveWindow.ScrollColumn = 3
ScrollRow プロパティの使用例下記のコード例は、行 10 が上端になるようにウィンドウをスクロールします
Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 10
＜参考＞
Sub myHOME() '最先頭左隅に移動(CTRL+HOME) SendKeys "^{HOME}" End Sub
Sub myDOWN() 'データの最下行(CTRL+下方向キー) SendKeys "^{DOWN}" ' ←End(xlDown) End Sub	Sub myUP() 'データの最上行(CTRL+上方向キー) SendKeys "^{UP}" ' ←End(xlUP) End Sub
Sub myPDOWN() 'PageDown (ページ下移動) SendKeys "{PGDN}" End Sub	Sub myPUP() 'PageUp (ページ上移動) SendKeys "{PGUP}" End Sub
参考キー操作 [CTRL]+[HOME] / [CTRL]+[End] / [CTRL]+[PgDn(ROLLUP)] / [CTRL]+[PgUP(ROLLDOWN)] [CTRL]+[↑] / [CTRL]+[↓] / [CTRL]+[→] / [CTRL]+[←]

●リンク先セルを画面の左上隅にして表示するには [Thisworkbook]

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'ハイパーリンク先を画面左上隅にしてジャンプします
Application.Goto Selection, True
End Sub

<参考>
Sub Test()
Application.Goto Range("S10"), True
End Sub
Goto メソッドの第２引数に True を指定すると、指定したセルが画面左上にきます。

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
'Hyperlink関数を使うとこのブロージャは実行されません
ActiveWindow.ScrollRow = Selection.Row
ActiveWindow.ScrollColumn = Selection.Column
End Sub

＜参考＞ブックやシートにハイパーリンクを設定した場合、
ドキュメントのリンク先セルを左上隅にして画面表示します。

●行表示切替 10～12行を表示非表示	＜参考＞行表示と非表示(2,4,6行)
Sub 行表示切替() ' 行表示非表示 With Rows("10:12") .Hidden = Not .Hidden End With End Sub	←With Range("2:2,4:4,6:6").EntireRow Range("2:2,4:4,6:6").EntireRow.Hidden = True '非表示 'Range("2:2,4:4,6:6").EntireRow.Hidden = False '表示

●列表示切替 A～C列を表示非表示	＜参考＞列表示と非表示(A,C,E列)
Sub 列表示切替() ' 列表示非表示 With Columns("A:C") .Hidden = Not .Hidden End With End Sub	←With Range("A:A,C:C,E:E").EntireColumn Range("A:A,C:C,E:E").EntireColumn.Hidden = True 'A,C,E列非表示 Range("A:A,C:C,E:E").EntireColumn.Hidden = False 'A,C,E列表示

●行列番号の表示/非表示を切り替え

Sub myDISP()
'画面の行列番号表示と非表示を切り替えます
With ActiveWindow
.DisplayHeadings = Not .DisplayHeadings
End With
End Sub

＜参考＞マクロを使用しない場合は
メニューの[ツール]-[オプション]-[表示]-[行列番号]にチェックを入れる/入れない[OK] の操作手順です。

＜参考＞エクセルメニュー表示/非表示を切り替え

Sub MenuBarOnOff()
'画面のメニュー表示と非表示を切り替えます

If Application.CommandBars("Worksheet Menu Bar").Enabled = True Then
Application.CommandBars("Worksheet Menu Bar").Enabled = False
Else
Application.CommandBars("Worksheet Menu Bar").Enabled = True
End If
End Sub

＜参考＞数式バー表示/非表示を切り替え

Sub myFXBarONOFF()
'数式バー表示/非表示を切り替えます
With Application
.DisplayFormulaBar = Not .DisplayFormulaBar
End With
End Sub

●TOP(1枚目)のシート表示/非表示を切り替え

Sub myTopSheetONOFF()
'TOPシート表示/非表示を切り替えます

With Worksheets(1) '最左(1枚目)のシートが対象
.Visible = Not .Visible
End With

End Sub

●特定のシートを完全非表示

Sub mySheetHidden()
'ブック内の特定シートを完全非表示にします
'シート再表示のコマンドを無効にします

Dim i As Byte

For i = 1 To 2 '非表示シート(左から1番目～2番目)を指定
Worksheets(i).Visible = xlSheetVeryHidden

Next i

End Sub

＜注＞ユーザーの目からは特定シートを完全に隠して見えなくなります。
＜注＞再表示するには
Worksheets(i).Visible = True を代入します。

●非表示のシートを再表示

Sub myShACT()
'非表示のシートをすべて表示します

Dim Sh As Object

Application.ScreenUpdating = False
For Each Sh In Sheets
Sh.Visible = True
Next
Application.ScreenUpdating = True
End Sub

●シートを昇順・降順で並べ替え

Sub mySHEETNAM()
'シートを昇順・降順に並べ替えします
'最優先データのシートを指定できます
Dim sh As Worksheet, s(), xl, temp
Dim i As Long, k As Long, l As Long, m As Long, n As Long
Const data = "A1" '最優先したいシートのセル指定
xl = MsgBox("シートを昇順・降順に並べ替えします ", vbYes)
ReDim s(1, Worksheets.Count - 1)
For Each sh In Worksheets
s(0, i) = sh.Range(data).Value
s(1, i) = sh.Name
i = i + 1
Next
k = 0
l = 1
For n = UBound(s, 2) To LBound(s, 2) Step -1
For i = LBound(s, 2) To n - 1
If s(k, i) > s(k, i + 1) Then
For m = 0 To 1
temp = s(m, i)
s(m, i) = s(m, i + 1)
s(m, i + 1) = temp
Next
End If
Next
Next
For i = LBound(s, 2) To UBound(s, 2) - 1
If xl Then
Sheets(s(l, i + 1)).Move before:=Sheets(s(l, i))
Else
Sheets(s(l, i + 1)).Move after:=Sheets(s(l, i))
End If
Next
End Sub

＜参考＞最優先（一番左側に表示）したいシートのセルの値が空白なら、シート名で並べ替えをします。
＜参考＞Const data = "A1" は全シートの同一セルを比較するセル指定です。
たとえば Sheet2 のセルA1の値が 1 で、その他のシートの値がゼロまたは空白なら
Sheet2が最左側に表示され、その他のシートを名前順に並べ替えを行います。

●行単位で列を並び替え

Sub ColumnSort()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim aRow As Range
For Each aRow In Selection.Rows
aRow.Sort Key1:=aRow, Orientation:=xlColumns
Next
Set aRow = Nothing
End Sub

＜注＞範囲を選択してから、コードを実行します。
＜参考＞マクロを使用せず標準で行うには
メニューの [データ(D)]-[並び替え(S)]-[オプション(O)]→方向を”列単位（Ｌ）”→[ＯＫ]をクリック

＜参考＞指定順序で並び替え

Sub mySortORDER()
'並べ替え文字の順序を指定、指定文字以外は昇順
'１行目は項目、並び替のキーがＢ列、データ範囲がA1:B10とする例
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B2:B10") _
, SortOn:=xlSortOnValues, Order:=xlAscending, _
CustomOrder:="1,8,2,9", DataOption:=xlSortNormal '並び替え指定文字
.SetRange Range("A1:B10") 'データ範囲
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

コード例では、１，８，２，９、３，４，５，... の順序で並び替えられます。

●選択範囲の数式を相対参照から絶対参照に切り替える

Sub test()
Dim c As Range

For Each c In Selection
If c.HasFormula Then
c.Formula = Application.ConvertFormula(Formula:=c.Formula, _
FromReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute)
End If
Next

End Sub

＜注＞範囲を選択してマクロを実行します。.

＜参考＞ToAbsolute: の部分で変換後の参照の種類を指定します。

xlAbsolute　　　　行列とも絶対参照（$A$1）
xlAbsRowRelColumn　行だけ絶対参照（A$1）
xlRelRowAbsColumn　列だけ絶対参照（$A1）
xlRelative　　　　行列とも相対参照（A1）

＜参考＞簡略コード例

Sub ConvertToAbsolute()
Dim aCell As Range
For Each aCell In Selection
aCell.Formula = Application.ConvertFormula(aCell.Formula, xlA1, , xlA1)
Next
End Sub

●数式が入力されているセルに色を付ける

Sub myFXCOLOR()
' 数式入力されたセルに色をつけます

With Cells
.Interior.ColorIndex = xlNone
On Error Resume Next
.SpecialCells(xlCellTypeFormulas).Interior.Color = vbYellow

End With
End Sub

＜参考＞シート使用範囲で数式が入力されているセルは黄色と指定しています。
＜参考＞選択範囲のみ、数式セルに色を付けるには、
With Cells を With Selection とコードを書き換えます。

●数式を完全非表示

Sub myFxHidden()
'入力されている数式を完全非表示にします
'シート保護解除にはパスワード(abc)が必要となります

ActiveSheet.Unprotect password:="abc" 'シート保護解除パスワード設定

Cells.FormulaHidden = False
ActiveSheet.UsedRange.SpecialCells _
(Type:=xlCellTypeFormulas).FormulaHidden = True
ActiveSheet.Protect password:="abc" 'パスワード

End Sub

＜参考＞シートを保護して、数式を数式バーに表示しません。ユーザーに隠したい場合に有効です。
＜注＞シート保護パスワードの扱いには注意が必要です。

●特定セルの数式を表示するには [Module1]

Function myFX(Rng As Range) As String
'ユーザー定義関数でシートに数式を表示します。
myFX = Rng.Formula
End Function

ワークシートで、数式を表示させたいセルに対して以下のように入力します。

＜例＞セルC1の数式を表示したい場合 =myFX(C1) とユーザー定義関数を別のセルに入力します。
セルC1に数式がない場合は、C1の値をそのまま表示します。

●選択範囲を１行おきに網掛け

Sub myStepPATTERN()
'選択範囲を１行ごとにパターン設定します。
Dim rw As Range
For Each rw In Selection
If rw.Row Mod 2 = 0 Then ' ←行指定
With rw.Interior
.Pattern = xlGray16 ' ←12.5％灰色網掛け
.PatternColorIndex = 15 ' ←25％灰色
End With
End If
Next rw
End Sub

＜参考＞上記コード例は、選択範囲に灰色の網掛けを指定しています。
＜参考＞コード中の 2 は１行おきを意味します。3 なら３行おきになります。

＜参考＞マクロを使用せずに行うには
範囲を選択して、メニューの[書式]-[条件付き書式] の設定で
「数式が」を選択して、式に=MOD(ROW(),2)=0　または　=MOD(ROW(),2)=1を入力する方法もあります。
偶数行、奇数行を区別するスタイルとして便利です。

＜参考＞選択範囲を１列おきに網掛け

Sub myStepPATTERN2()
'選択範囲を１列ごとにパターン設定します。
Dim col As Range
For Each col In Selection
If col.Column Mod 2 = 0 Then ' ←列指定
With col.Interior
.Pattern = xlGray16 ' ←12.5％灰色網掛け
.PatternColorIndex = 15 ' ←25％灰色
End With
End If
Next col
End Sub

●一定間隔で行挿入

Sub 一定間隔行挿入()
'指定範囲に一定間隔で空白行を挿入します。
Dim r As Long
For r = 20 To 2 Step -1 '挿入範囲を行2～行20に指定
Range(Rows(r), Rows(r)).Insert '空白１行を順次挿入
Next
End Sub

＜参考＞行の挿入範囲をシートの行２～行２０までとしています。
例えば途中に２行ずつ挿入するには Range(Rows(r), Rows(r + 1)).Insert と書き換えてください。

■１行おき挿入

Sub 一行おきに行挿入()
Dim n As Integer
For n = 1 To 100 '←100はデータ最終行
ActiveSheet.Cells(2 * n, 1).EntireRow.Insert (xlShiftDown)
Next n
End Sub

■１列おき挿入

Sub 一列おきに列挿入()
Dim n As Integer
For n = 1 To 100 '←100はデータ最終列
ActiveSheet.Cells(1, n * 2).EntireColumn.Insert (xlShiftToRight)
Next n
End Sub

＜参考＞数式を利用して一定間隔にデータを書き込む

元データがシート１にある場合、別シートに下記数式を設定
A1セル数式 =IF(MOD(ROW()-1,2)=0,OFFSET(Sheet1!A$1,(ROW()-1)/2,0),"") とします。
その後、A1セルを下方向にコピーします。

上記数式例では、元データに１行ずつ新規行挿入された結果となります。
２行ずつ挿入したい場合は、数式中の太字部分２を３と書き換えてください。

●数値によりセルに順次色付け表示、文字の場合はクリア

Option Explicit

Sub myCellCOLOR(Seru As Object)
'セル入力された値に応じてパターン(色)を設定します
Dim moji As Integer
'入力された値が数字かどうかの判定
If IsNumeric(Seru.Value) Then
moji = Seru.Value

Select Case (moji)
Case 0
Seru.Interior.ColorIndex = xlNone '塗りつぶしなし
Case 1 To 30
Seru.Interior.ColorIndex = 3 '赤
Case 31 To 50
Seru.Interior.ColorIndex = 6 '黄
Case 51 To 89
Seru.Interior.ColorIndex = 35 '薄い緑
Case 90 To 100
Seru.Interior.ColorIndex = 4 '明るい緑
Case Else
Seru.Interior.ColorIndex = 15 '25％灰色
End Select
Else
Seru.Interior.ColorIndex = xlNone '塗りつぶしなし

End If
End Sub
Private Sub workSheet_Change(ByVal Target As Range)
Dim moji As Integer 'String
Dim Seru As Object
'一つだけセルを選択したときの処理
If Target.Count = 1 Then
Set Seru = Cells(Target.Row, Target.Column)
Call myCellCOLOR(Seru)
'複数のセルを選択したときの処理
ElseIf Target.Count > 1 Then
For Each Seru In Selection
Call myCellCOLOR(Seru)
Next Seru
End If
End Sub

＜参考＞値がゼロ=標準（着色なし）、1～30=赤、31～50=黄、51～89=薄い緑、90～100=明るい緑
それ以外の値=灰色としています。

●数値によりセル色付け（指定範囲内）

●数値によりセル色付け（A列使用範囲）

Option Explicit
Sub myCellCOLOR2()
'セル範囲 A1:C10 に対してループを行います
'入力値に対して、パターン(色)を一括で設定します

Dim c As Object
Range("A1:C10").Interior.ColorIndex = xlNone '色をクリア

For Each c In Range("A1:C10") '範囲を設定

If c.Value = "" Then
c.Interior.ColorIndex = xlNone '塗りつぶしなし
ElseIf c.Value >= 0 And c.Value <= 30 Then
c.Interior.ColorIndex = 3 '赤
ElseIf c.Value > 30 And c.Value < 80 Then
c.Interior.ColorIndex = 6 '黄色
ElseIf c.Value >= 80 And c.Value <= 100 Then
c.Interior.ColorIndex = 8 '水色
End If

Next c
End Sub

Option Explicit
Sub myCellCOLOR3()
'値により、A列にパターン(色)を設定します

Dim i As Long
UsedRange.Columns("A").Interior.ColorIndex = xlNone '項目以外の使用範囲を色クリア

'A列の使用範囲を下から上へループ
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1

'A列の値により、セルに色をつけます
'値空白・ゼロ=赤、59まで=灰色、60以上=黄色、80以上=明るい緑、100上=無色

If IsNumeric(Cells(i, 1).Value) = False Then _
Cells(i, 1).Interior.ColorIndex = xlNone '文字の場合は色なし

If Cells(i, 1).Value = 0 Then Cells(i, 1).Interior.ColorIndex = 3 '赤
If Cells(i, 1).Value <> False Then Cells(i, 1).Interior.ColorIndex = 15 '灰色
If Cells(i, 1).Value >= 60 Then Cells(i, 1).Interior.ColorIndex = 6 '黄色
If Cells(i, 1).Value >= 80 Then Cells(i, 1).Interior.ColorIndex = 4 '明るい緑
If Cells(i, 1).Value > 100 Then Cells(i, 1).Interior.ColorIndex = 0 '無色

Next i
End Sub

●数値によりセル色付け（選択範囲内）

●数値により行全体自動色付け（使用範囲内）

Option Explicit
Sub myCellCOLOR4()
'セル選択範囲の値により、パターン(色)を設定します
'文字や空白=塗りつぶしなし
'ゼロ・30まで=赤、31～50=黄、51～80=薄い緑、81～100=明るい緑

Dim Seru As Object

For Each Seru In Selection
Select Case (Seru)
Case "" '文字や空白の場合
Seru.Interior.ColorIndex = xlNone '無色
Case 0, Is <= 30
Seru.Interior.ColorIndex = 3 '赤
Case 31 To 50
Seru.Interior.ColorIndex = 6 '黄
Case 51 To 80
Seru.Interior.ColorIndex = 35 '薄い緑
Case 81 To 100
Seru.Interior.ColorIndex = 4 '明るい緑
Case Else
End Select
Next
End Sub

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'A列の値により、行全体にパターン(色)を自動設定します

Dim i As Long
Application.ScreenUpdating = False
UsedRange.EntireRow.Interior.ColorIndex = xlNone 'シート使用範囲を色クリア

'A列の使用範囲を下から上へループ
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'To 1で最上行指定

'A列のセル値により、行全体に色をつけます
'ゼロ=赤、空白=無色、80以上=黄色、100上=無色、文字=灰色

If Cells(i, 1).Value = 0 Then Cells(i, 1).EntireRow.Interior.ColorIndex = 3 '赤
If Cells(i, 1).Value = "" Then Cells(i, 1).EntireRow.Interior.ColorIndex = xlNone '無色
If Cells(i, 1).Value >= 80 Then Cells(i, 1).EntireRow.Interior.ColorIndex = 6 '黄色
If Cells(i, 1).Value > 100 Then Cells(i, 1).EntireRow.Interior.ColorIndex = 0 '無色
If IsNumeric(Cells(i, 1).Value) = False Then Cells(i, 1).EntireRow.Interior.ColorIndex = 15 '灰色

Next i
Application.ScreenUpdating = True
End Sub

●選択範囲のセル色をカウント

Sub countcolor()
'選択範囲のセル色をカウントします
'A列にセル色、B列に個数を書き出します
Dim coldic, r As Range, i As Long, k
Set coldic = CreateObject("Scripting.Dictionary")
For Each r In Selection
If coldic.exists(r.Interior.ColorIndex) Then
coldic.Item(r.Interior.ColorIndex) = _
coldic.Item(r.Interior.ColorIndex) + 1
Else
coldic.Add r.Interior.ColorIndex, 1
End If
Next
i = 1

With Columns("A:B") '旧データをクリア
.ClearContents
.Interior.ColorIndex = xlNone
End With

Range("A1").Select 'データを書き出す基点セル
Range("A1") = "色"
Range("A1").Offset(, 1) = "個数"

For Each k In coldic.keys
Selection(i + 1, 1).Interior.ColorIndex = k
Selection(i + 1, 2) = coldic.Item(k)
i = i + 1
Next
End Sub

＜注＞データを書き込むため、A列とB列のデータは削除されます。
＜参考＞カウントするセル範囲を選択してマクロを実行します。
＜参考＞上記コードはセルA1以下に色、B1以下に個数を書き出します。

●ユーザー定義関数で合計 [Module1]

Function SumRed(myRange As Range) As Single
'ユーザー定義関数で指定範囲の赤色文字の合計を返します。
Dim cl As Range
For Each cl In myRange
If cl.Font.ColorIndex = 3 Then
SumRed = SumRed + cl.Value
End If
Next
End Function

Function SumBlue(myRange As Range) As Single
'ユーザー定義関数で指定範囲の青色文字の合計を返します。
Dim cl As Range
For Each cl In myRange
If cl.Font.ColorIndex = 5 Then
SumBlue = SumBlue + cl.Value
End If
Next
End Function

Function SumYellow(myRange As Range) As Single
'ユーザー定義関数で指定範囲の黄色セルの合計を返します。
Dim cl As Range
For Each cl In myRange
If cl.Interior.ColorIndex = 6 Then
SumYellow = SumYellow + cl.Value
End If
Next
End Function

＜参考＞特定のブックのみで使う場合は　そのブックのVBA標準モジュール[Module1]に記入します。
いろいろなブックで使うのであれば　Personal.xls に　関数マクロを保存します。

＜関数の使い方＞合計値を表示したいセルを選択し、下記のようにユーザー定義関数を入力します。
=SumRed(A1:A20) 赤色文字の合計値
=SumBlue(A1:A20) 青色文字の合計値
=SumYellow(A1:A20) セルの色が黄色の合計値

または、合計値を表示するセルを選択し、数式バーの fx をクリックします。
関数の分類で「ユーザー定義」を選ぶと一覧の中に、
SumRed SumBlue SumYellow が表示されます。
ユーザー定義関数を指定し、合計するセル範囲を選択するとシートに計算結果が表示されます。

＜注＞関数中の A1:A20 は計算対象のセル範囲の一例です。
＜注＞セル範囲に条件付き書式が設定されている場合は計算されません。
＜注＞自動再計算されません

＜参考＞コード例は赤色文字、青色文字、黄色セルなどとしていますが、
必要に応じてエクセルの標準カラーパレットインデックス（色番号）を参考に、指定を変更してください。

＜参考＞赤色文字をカウント

Function RedCount(myRange As Range) As Integer
'ユーザー定義関数で指定範囲の赤色文字のセル個数をカウントします。
Dim i As Integer, cl As Range
For Each cl In myRange
If cl.Font.ColorIndex = 3 Then i = i + 1
Next
RedCount = i
End Function

ユーザー定義関数名を =RedCount(A1:A20) のように指定します。

＜参考＞値の平方根を返す

Function SquareRoot(NumberArg As Double) As Double
'ユーザー定義関数で引数として渡された値の平方根を返します。
If NumberArg < 0 Then ' 引数を評価
Exit Function ' 終了して、呼び出し側のプロシージャに戻る
Else
SquareRoot = Sqr(NumberArg) ' 平方根を返す
End If
End Function

ユーザー定義関数名を =SquareRoot("A1") のように指定します。

●ユーザー定義関数で勤務時間計算 [Module1]

'勤務時間計算
'ユーザー定義関数 =workhour(A1,B1) A1は出社時刻、B1は退社時刻
'関数を入れたセル書式は標準 (単位を時間でなく､数値として処理)
'1５分単位で時間数を求め、その際の端数は切り捨てます
'＜条件＞勤務時間表示は 0.25単位
'始業は 8：30 からとする
'12：00～12：50 まで昼休み
'15：00～15：10 まで休憩時間
'終業は 17：15 それ以降退社までは残業時間

Function workhour(inH As Date, outH As Date)
Dim k1 As Long, k2 As Long, tmp
If inH = 0 Or outH = 0 Or inH >= outH Then Exit Function

If inH <= CDate("8:30") Then
inH = CDate("8:30")
ElseIf inH >= CDate("12:00") And inH <= CDate("12:50") Then
inH = CDate("12:00")
End If
If outH >= CDate("12:00") And outH <= CDate("12:50") Then
outH = CDate("12:00")
ElseIf outH >= CDate("15:00") And outH <= CDate("15:10") Then
outH = CDate("15:00")
ElseIf outH >= CDate("17:15") Then
outH = CDate("17:15")
End If
If inH <= CDate("12:00") And outH >= CDate("12:50") Then
k1 = 1
End If
If outH >= CDate("15:10") Then
k2 = 1
End If
If inH >= CDate("15:00") Then
k2 = 0
End If
tmp = outH - inH - k1 * CDate("00:50") - k2 * CDate("00:10")
If inH = 0 Or outH = 0 Or inH >= outH Then
workhour = 0
Else
workhour = Application.Floor((tmp + CDate("0:0:1")) * 24, CDate("0:15") * 24)
End If
End Function

Function OverH(Endt As Date) As Single
'残業時間を求めるユーザー定義関数 =OverH(B1)
Select Case Endt * 24
Case Is < 17.5
OverH = 0
Case Else
OverH = WorksheetFunction.Floor(Endt * 24 - 17.25, 0.25)
End Select
End Function

＜注＞A1セルは出社時刻、B1セルは退社時刻としています。
＜注＞勤務時間を０.２５単位での表示としています。
＜注＞出社と退社のセル書式は[時刻]、勤務時間計算のセル書式は[標準] とします。
＜参考＞始業から終業までの定時労働時間労働時間関数 =workhour(A1,B1) と指定します。
＜参考＞定時以降は残業時間残業時間関数 =OverH(B1) と指定します。

＜参考＞Sheet2ページ勤務時間計算（始業：９時、終業：１７時、休憩：12時～１3時、とした場合）

●各種ダイアログを表示

Option Explicit
Sub test1()
'例えば”ファイルを開く”ダイアログでファイル名を初期状態で表示させておく
Application.Dialogs(xlDialogOpen).Show ("c:windows\ファイル名.xls")
End Sub

Sub test1a()
'また､ユーザに操作を強制する場合には､Showメソッドで表示された場合のダイア'ログが”OK”の場合には"True"が返り、
”キャンセル”の場合には"False"が返される特性を生かして以下のようにすることもできます｡
Dim Ret As Boolean
Do
Ret = Application.Dialogs(xlDialogOpen).Show("c:\ファイル名.xls")
Loop While Ret = False
End Sub

Sub Test2()
'画像挿入
Application.Dialogs(xlDialogInsertPicture).Show
End Sub

Sub test3()
'関数の貼り付け
Application.Dialogs(xlDialogFunctionWizard).Show
End Sub

Sub test4()
'表示形式
Application.Dialogs(xlDialogFormatNumber).Show
End Sub

Sub test5()
'フォントの設定
Application.Dialogs(xlDialogFormatFont).Show
End Sub

Sub test6()
'ウィンドウ選択
Application.Dialogs(xlDialogActivate).Show
End Sub

Sub test7()
'置き換え
Application.Dialogs(xlDialogFormulaReplace).Show "検索文字", "置き換え文字"
End Sub

Sub test8()
'検索
Application.Dialogs(xlDialogFormulaFind).Show "検索文字をここに入力"
End Sub

Sub test9()
'印刷設定
Application.Dialogs(xlDialogPageSetup).Show
End Sub

Sub test10()
印刷（初期設定を指定2ページ指定、１～５ページ、３部）
Application.Dialogs(xlDialogPrint).Show 2, 1, 5, 3
End Sub

Sub test11()
'行、列の印刷タイトル
Application.Dialogs(xlDialogSetPrintTitles).Show
End Sub

Sub test12()
'並び替え
Application.Dialogs(xlDialogSort).Show
End Sub

Sub test13()
'ファイルを開く
Application.Dialogs(xlDialogOpen).Show
End Sub

＜参考＞
オートフィルタアイコンON/OFF
Range("A1").AutoFilter

フィルタオプションの設定
Application.Dialogs(xlDialogFilterAdvanced).Show
Range("AccessData").Application.Dialogs(xlDialogFilterAdvanced).Show

●値の置換	●単純な文字置換
Sub 値の置換() 'セル範囲 A1:C10 に対してループを行います 'セルの値が 0 の場合は、値を空白に置き換えます Dim c As Object For Each c In Range("A1:C10") If c.Value = 0 Then '←論理式設定 >, < , >=, = ,<> c.Value = "" '←置換後の値設定 End If Next c End Sub	Sub 単純置換() 'セル範囲の文字を単純に置き換えます｡ Range("A1:C10").Replace What:="0", Replacement:="" End Sub 参考：シート全体に適用 ActiveWindow.DisplayZeros = True 'ゼロ値を表示 ActiveWindow.DisplayZeros = False 'ゼロ値を非表示

●文字種変換
Sub myStrConv() '選択範囲の文字を半角先頭大文字に変換 Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c.Value, vbNarrow + vbProperCase) '半角＋先頭大文字 ' c.Value = StrConv(c.Value, vbUpperCase) 'ABC大文字 ' c.Value = StrConv(c.Value, vbLowerCase) 'abc小文字 ' c.Value = StrConv(c.Value, vbProperCase) 'Abc先頭のみ大文字 ' c.Value = StrConv(c.Value, vbWide) '全角文字 ' c.Value = StrConv(c.Value, vbNarrow) '半角文字 Next End Sub
＜参考＞・引数conversionで指定する定数一覧（VbStrConv）定数　　　　　　　値　　　内容 vbUpperCase　　　　1　　　文字列を大文字に変換 vbLowerCase　　　　2　　　文字列を小文字に変換 vbProperCase　　　 3　　　文字列の各単語の先頭の文字を大文字に変換します vbWide　　　　　　 4　　　文字列内の半角文字を全角文字に変換 vbNarrow　　　　　 8　　　文字列内の全角文字を半角文字に変換 vbKatakana　　　　16　　　文字列内のひらがなをカタカナに変換 vbHiragana　　　　32　　　文字列内のカタカナをひらがなに変換 vbUnicode　　　　 64　　　システムの既定のコードページを使って文字列をUnicodeに変換 vbFromUnicode　 128　　　文字列をUnicodeからシステムの既定のコードページに変換　構文　StrConv(String, Conversion, LCID) 　設定項目内容　String　　　　　変換対象の文字列を指定　[省略不可] 　Conversion　　　変換の種類の合計値を指定（表参照）　[省略不可] 　LCID　　　　　　国別情報識別子 (LCID) を指定　[省略可能]
<参考>変換
●全角文字に変換	●半角文字に変換
Sub myZENKAKU() Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c.Value, vbWide) '全角文字 Next End Sub	Sub myHANKAKU() Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c.Value, vbNarrow) '半角文字 Next End Sub
<参考>簡略形の書き方 c.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c, vbWide + vbHiragana) <参考>シート全体の使用セルを対象にする場合 For Each c In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants) For Each c In ActiveSheet.UsedRange.Cells
●半角カタカナを全角に変換	●カタカナ全角半角文字をひらがなに変換
Sub myKANALAGE() '選択範囲の半角カナを全角にします Dim i As Integer Dim myLetter As String Dim myStr As String Dim myCell As Range For Each myCell In Selection ActiveSheet.UsedRange myStr = myCell.Value i = 1 Do While (i <= Len(myStr)) myLetter = Mid(myStr, i, 1) Select Case Asc(myLetter) Case 167 To 181, 197 To 201, 207 To 223 myStr = Left(myStr, i - 1) & StrConv(myLetter, vbWide) _ & Mid(myStr, i + 1) Case 182 To 196, 202 To 206 If (i < Len(myStr)) Then Select Case Asc(Mid(myStr, i + 1, 1)) Case 222 To 223 myStr = Left(myStr, i - 1) & _ StrConv(Mid(myStr, i, 2), vbWide) & _ Mid(myStr, i + 2) Case Else myStr = Left(myStr, i - 1) & StrConv(myLetter, vbWide) & _ Mid(myStr, i + 1) End Select Else myStr = Left(myStr, i - 1) & StrConv(myLetter, vbWide) & _ Mid(myStr, i + 1) End If End Select i = i + 1 Loop myCell.Value = myStr Next End Sub	Sub myHIRAGANA() Dim c As Range '選択範囲のカタカナ全角/半角文字をひらがなに変換します For Each c In Selection c.Value = StrConv(c, vbWide + vbHiragana) Next End Sub Dim c As Range '選択範囲のカタカナ全角/半角文字をひらがなに変換します For Each c In Selection c.Value = StrConv(c, vbWide + vbHiragana) Next End Sub

●アルファベットを小文字に変換
Sub myABCHAN() Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c.Value, vbLowerCase) 'アルファベット小文字 Next End Sub
●アルファベットを大文字に変換(1)	●アルファベットを大文字に変換(Ucase関数)
Sub myABCZEN() Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells (xlCellTypeConstants) c.Value = StrConv(c.Value, vbUpperCase) 'アルファベット大文字 Next End Sub	Sub myABCZEN2() 'アルファベットの小文字のみ大文字に変換(Ucase関数) Dim c As Range For Each c In Selection ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants) c.Value = UCase(c.Value) '小文字を大文字に変換 Next End Sub <参考>c.Value = LCase(c.Value) '小文字に変換(Lcase関数)
●数字を漢数字に変換
Sub myKANSUUJI() '選択範囲の数字を漢数字に変換します Dim a, k, i For Each a In Selection a.Value = Application.WorksheetFunction.Asc(a.Value) Next k = Array("〇", "一", "二", "三", "四", "五", _ 六, "七", "八", "九") For i = 0 To 9 Selection.Replace i, k(i) Next End Sub
<参考> 選択中のシートのなかの定数すべてを対象に全角⇒半角変換 Sub ConvChrs() Dim wCell For Each wCell In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants) wCell.Value = StrConv(wCell.Value, vbNarrow) Next End Sub

●フリガナ付け（別セル）

●文字上にふりがな付け

Sub ふりがな()
'選択範囲の右隣セルにふりがなを書き込みます
'右側セルにデータがあれば置き換えられます
'変換前データが、ひらがな=カタカナ,アルファベット=無変換となります
Dim r As Range
For Each r In Selection '選択範囲
r.Offset(, 1).Value = r.Phonetic.Text
r.Phonetic.CharacterType = xlHiragana 'ひらがな(省略=カタカナ)

Next r
End Sub

Sub 文字上ふりがな()
'範囲内の文字にふりがなを設定します
Dim r As Range
Set r = Range("a1:a10") '範囲設定
With r.Phonetic
.CharacterType = xlHiragana
.Alignment = xlPhoneticAlignCenter
.Font.Name = "ＭＳＰ"
.Font.FontStyle = ""
.Font.Size = 6
.Font.Strikethrough = False
.Font.Underline = xlUnderlineStyleNone
.Font.ColorIndex = xlAutomatic
.Visible = True
End With
End Sub

●大文字と大文字の間にスペースを入れる [Module1]
Function SplitCapital(Src As String) As String With CreateObject("VBScript.RegExp") .Pattern = "([^ _])(?=[A-Z])" .Global = True .IgnoreCase = False SplitCapital = .Replace(Src, "$1 ") End With End Function	ユーザー定義関数 =SplitCapital(A1) <例> ExcelVBA → Excel V B A <例> NOCOPY →N O C O P Y

●セル中の数字を、すべて取り出します
Sub myNumORDER() '選択されたセルの数字のみ、右隣列に取り出します。 Dim cl As Range, l As Integer Dim sNum As String, n As Integer For Each cl In Selection sNum = "" If IsNumeric(cl.Value) Then cl.Value = CStr(cl.Value) End If l = Len(cl.Value) For n = 1 To l If Asc(Mid(cl.Value, n, 1)) > 47 And _ Asc(Mid(cl.Value, n, 1)) < 58 Then sNum = sNum & Mid(cl.Value, n, 1) End If Next cl.Offset(0, 1).Value = sNum Next End Sub
＜注＞選択されたセルの右列にデータがある場合、取り出した値に書き換えられます。新しい列を挿入してからコードを実行してください。＜注＞英字と数字が混在するデータを対象としています。
●ユーザー定義関数でセル中の数字を取り出します [Modure1]
Function ExtractNum1(strTarget As String) As String 'セルの数字のみを、すべて取り出します With CreateObject("VBScript.RegExp") .IgnoreCase = True: .Global = True .Pattern = "(^\|\D+)(\d{})(\D+\|$)\|\D+" ExtractNum1 = Replace(Trim(.Replace(strTarget, " ")), " ", "") End With End Function	ユーザー定義関数 =ExtractNum1(A1) <例> code-12345 → 12345 <例> ＩＤ：100001 → 100001
<参考>セル中の文字のみを取り出す .Pattern = "\d{" & 1 & ",}" '文字のみ <参考>セル中の連続数字３桁以上の部分を取り出す .Pattern = "(^\|\D+)(\d{1,2})(\D+\|$)\|\D+" <参考>取り出す値の間に、区切り文字(カンマ)を入れる場合 ExtractNum1 = Replace(Trim(.Replace(strTarget, " ")), " ", ",")

●文字列中のかっこ（）で囲まれた部分を取り出します
Sub myKAKKO() '文字列中のかっこ( )で囲まれた部分を取り出します ' Const Chr1 As String = "(" Const Chr2 As String = ")" Dim c As Range Dim Srch As String Dim Btwn As String For Each c In Selection Srch = c.Value & Chr1 & Chr2 Btwn = Mid(Srch, InStr(Srch, Chr1) + 1, _ InStr(Srch, Chr2) - InStr(Srch, Chr1) - 1) c.Offset(, 1).Value = Btwn Next End Sub
＜注＞選択範囲の小文字のかっこ( ) を対象としています。＜参考＞Kansu-Sample で数式を用いた例を紹介しています。

TOP / FAQ1 / FAQ2 / FAQ3 / 上へ