|
オフィス・ブールは、Excel全般について皆さまのお仕事をサポートします。
|
|
Excel編へ
|
●フォルダを指定してファイルを選択したいとき
|
通常「ファイルを開くダイアログ」を表示した場合、「ツール」→「オプション」のExcelのカレントフォルダ欄に設定されたフォルダが最初に開きます。
これを任意のフォルダを指定して開くようにするには、Application.GetOpenFilenameを実行する前にWScriptのCurrentDirectoryプロパティのカレントフォルダを変更する必要があります。
CurDirで現在のパスが取り出せますので、実行前パスを保存しておき、ファイルを選択した後は元のカレントフォルダに戻してあげたほうがよいでしょう。
Public Sub SelectedFolOpen()
'フォルダを指定して「ファイルを開く」ダイアログを呼び出す
Dim myCurDir As String
Dim myFile As String
Dim myTitle As String
myTitle="ファイルの選択"
'実行前のカレントフォルダ記憶
myCurDir = CurDir
'カレントフォルダ変更
CreateObject("WScript.Shell").CurrentDirectory = "D:\"
myFile = Application.GetOpenFilename("Excelファイル,*.xls", , myTitle)
'カレントフォルダを元に戻す
CreateObject("WScript.Shell").CurrentDirectory = myCurDir
If myFile = "False" Then
MsgBox "キャンセルされました。"
End If
End Sub
|
|
|
●データが入力されているセル幅を自動調節したいとき
|
|
データが入力されている列に対して、そのセル幅を自動調節してくれます。
UsedRangeプロパティを使用することで、対象セル範囲を限定しています。
Public Sub AutoFitMac()
'セル幅を自動調節する
ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub
|
|
|
●テキストファイルを読み書きしたいとき
|
|
テキストファイルの読み書きは、VBのOpenステートメントを使用する方法とファイルシステムオブジェクトを利用する方法があります。
Openステートメントは古くから使われており、分かりやすいですが定型的な処理しかできません。
ファイルシステムオブジェクトの方は様々なメソッドやプロパティが用意されているので、もっと細かな処理ができます。
ここでは両方のコーディング例を掲載しています。
用途に応じて使い方を考えてみてください。
Public Sub ReadText1()
' Openステートメントを使用
' 行単位で読み込み
Dim FileNumber As Long
Dim FilePath As String
Dim TextLine As String
Dim ar As Variant
Dim i As Long
Dim gyo As Long
FileNumber = FreeFile
FilePath = ThisWorkbook.Path & "\test.txt"
Open FilePath For Input As #FileNumber
gyo = 1
Do While Not EOF(FileNumber)
Line Input #FileNumber, TextLine
ar = Split(TextLine, ",")
For i = 0 To UBound(ar)
Cells(gyo, i + 1).Value = ar(i)
Next i
gyo = gyo + 1
Loop
Close #FileNumber
End Sub
Public Sub ReadText2()
' Openステートメントを使用
' 項目単位で読み込み
Dim FileNumber As Long
Dim FilePath As String
Dim ar(1 To 7) As String
Dim i As Long
Dim gyo As Long
FileNumber = FreeFile
FilePath = ThisWorkbook.Path & "\test.txt"
Open FilePath For Input As #FileNumber
gyo = 1
Do While Not EOF(FileNumber)
Input #FileNumber, ar(1), ar(2), ar(3), ar(4), ar(5), ar(6), ar(7)
For i = 1 To UBound(ar)
Cells(gyo, i).Value = ar(i)
Next i
gyo = gyo + 1
Loop
Close #FileNumber
End Sub
Public Sub ReadText3()
' FileSystemObjectを利用
' テキストファイルの読み込み（行単位、カンマ区切り）
Dim FSO As Object
Dim TSO As Object
Dim TextLine As String
Dim FilePath As String
Dim ar As Variant
Dim i As Long
Dim gyo As Long
FilePath = ThisWorkbook.Path & "\test.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
gyo = 1
Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
With TSO
Do Until ..AtEndOfStream
TextLine = .ReadLine
ar = Split(TextLine, ",")
For i = 0 To UBound(ar)
Cells(gyo, i + 1).Value = ar(i)
Next i
gyo = gyo + 1
Loop
.Close
End With
End Sub
Public Sub ReadText4()
' FileSystemObjectを利用
' テキストファイルの読み込み（行単位、タブ区切り）
Dim FSO As Object
Dim TSO As Object
Dim TextLine As String
Dim FilePath As String
Dim ar As Variant
Dim i As Long
Dim gyo As Long
FilePath = ThisWorkbook.Path & "\test.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
gyo = 1
Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
With TSO
Do Until .AtEndOfStream
TextLine = .ReadLine
ar = Split(TextLine, vbTab)
For i = 0 To UBound(ar)
Cells(gyo, i + 1).Value = ar(i)
Next i
gyo = gyo + 1
Loop
.Close
End With
End Sub
Public Sub WriteText1()
' Openステートメントを使用
' テキストファイルの書き込み（行単位、上書き）
Dim FileNumber As Long
Dim FilePath As String
Dim TextLine As String
Dim gyo As Long
FileNumber = FreeFile
FilePath = ThisWorkbook.Path & "\test.txt"
Open FilePath For Output As #FileNumber
gyo = 1
Do While Cells(gyo, 1).Value <> ""
TextLine = Cells(gyo, 1).Value
Print #FileNumber, TextLine
gyo = gyo + 1
Loop
Close #FileNumber
End Sub
Public Sub WriteText2()
' Openステートメントを使用
' テキストファイルの書き込み（行単位、追記）
Dim FileNumber As Long
Dim FilePath As String
Dim TextLine As String
Dim gyo As Long
FileNumber = FreeFile
FilePath = ThisWorkbook.Path & "\test.txt"
Open FilePath For Append As #FileNumber
gyo = 1
Do While Cells(gyo, 1).Value <> ""
TextLine = Cells(gyo, 1).Value
Print #FileNumber, TextLine
gyo = gyo + 1
Loop
Close #FileNumber
End Sub
Public Sub WriteText3()
' Openステートメントを使用
' テキストファイルの書き込み（項目単位、上書き）
Dim FileNumber As Long
Dim FilePath As String
Dim gyo As Long
FileNumber = FreeFile
FilePath = ThisWorkbook.Path & "\test.txt"
Open FilePath For Output As #FileNumber
gyo = 1
Do While Cells(gyo, 1).Value <> ""
Write #FileNumber, Cells(gyo, 1).Value, Cells(gyo, 2).Value
gyo = gyo + 1
Loop
Close #FileNumber
End Sub
Public Sub WriteText4()
' FileSystemObjectを利用
' テキストファイルの書き込み（行単位、カンマ区切り）
Dim FSO As Object
Dim OSB As Object
Dim FilePath As String
Dim gyo As Long
FilePath = ThisWorkbook.Path & "\test.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
'2→上書きモード※ True→ファイルが存在しなければ新規作成
Set OSB = FSO.OpenTextFile(FilePath, 2, True)
gyo = 1
Do Until Cells(gyo, 1).Value = ""
OSB.WriteLine Cells(gyo, 1).Value & "," & Cells(gyo, 2).Value
gyo = gyo + 1
Loop
OSB.Close
End Sub
※追記モードで開く場合は8を、読込モードは1を指定してください。
|
|
|
●文字列を選択状態にしたいとき
|
|
テキストボックスに入力した値をチェックして、エラーの場合その文字列を選択状態（反転表示）にさせてオペレータに知らせたい場合に便利です。
このサンプルコードは、ユーザーフォームにTextBox1が配置してあり、そのボックスに入力された文字列をコマンドボタンで選択状態にする例です。
実際はエラーチェックルーティンと組み合わせて使われることが多いと思います。
SelStartプロパティは文字列をどの位置から選択するのかを指定し、SelLengthプロパティで選択範囲の長さを指定します。
この例ではLen関数でテキストボックスに入力されている文字列の長さを調べ、その値をSelLengthプロパティに設定しています。
Private Sub CommandButton1_Click()
'テキストボックスに入力された
'文字列を選択状態にする
With TextBox1
.SetFocus
.SelStart = 0
.SelLength = Len(.Value)
End With
End Sub
|
|
|
●シート行の最大値65536を使わずにデータの最後行を取得
|
|
データの最後の行を求める場合、ワークシートの最大行番号65536行を指定して、そこから上に探索する方法が一般的です。
《例》EndRow = Sheet1.Range("A65536").End(xlUp).Row
しかし、これだとExcelの仕様が変わり、最大行が65536行でなくなった場合に問題が発生することが予想されます。
そこまで考えるなら次のコードのように変更すれば、大丈夫でしょう。
シートの最大値をコードで取得して、その値から上方に調べていくやり方です。
Dim RowsCount As Long
Dim EndRow As Long
With Worksheets("Sheet1")
RowsCount = .Rows.Count
EndRow = .Range("A" & RowsCount).End(xlUp).Row
End With
|
|
|
●フォームを表示した状態でワークシートをスクロールさせたいとき
|
|
通常はフォームを表示する場合はUserForm1.Showと記述しますので、モーダルフォームとなり、フォーム以外での操作は受け付けられなくなります。
他の操作（ワークシートのスクロールなど）を行いたいときは、いったんフォームを閉じてから操作をしなければなりません。
しかしフォームをモードレス状態で開くと、フォームが表示されていても後ろにあるワークシートを触れるようになります。もちろんスクロールも自由自在です。
このようにモーダルフォームとは、そのフォームを閉じない限り他の操作ができないものを言い（アプリケーション内の他のフォームは無効になりますが、他のアプリケーションのフォームは有効です）、モードレスフォームとは、そのフォームを閉じなくても、別なオブジェクトを操作することができるものをいいます。
VBAではShowメソッドの引数にvbModelessを指定すれば、モードレスフォームとなります。
ただしOffice 97では、ユーザーフォームは常にモーダルでしか表示できません。
Public Sub callfrom()
UserForm1.Show vbModeless
End Sub
|
|
|
●ファイル名を変更（リネーム）したいとき
|
|
ファイル名またはフォルダ名の名前を変更するにはNameステートメントを使います。
また、ファイル名を変更して、他のフォルダにファイルを移動させることもできます。
まず最初にMotoFileで名前を変更するファイル名を指定します。
次にNewFileで新しいファイル名を指定します。
どちらもフルパス（ドライブ名及びフォルダ名を含める）で記述してください。
ただしNewFileには、既に存在しているファイル名は指定できません。実際に運用する場合にはエラートラップが必要となります。
またNameステートメントは、ドライブ間ではファイルを移動しますが、MotoFileとNewFileで指定したドライブ名が同じ場合は、単に既存のフォルダの名前を変更します。
ファイルやフォルダを新しく作成することはできません。
現在、開いているファイルに対してNameステートメントを実行してもエラーにはなりませんが、内容を変更した場合は、閉じる際に「名前を付けて保存」になります。
さらにDOSコマンドのように (*) や (?) のワイルド カード文字が指定できないので、場合によっては自分で処理を付け加える必要があるでしょう。
Public Sub Rename()
'ファイル名を付け替える（リネーム）
Dim MotoFile As String
Dim NewFile As String
MotoFile = ThisWorkbook.Path & "\" & "old.txt"
NewFile = ThisWorkbook.Path & "\" & "new.txt"
Name MotoFile As NewFile
End Sub
|
|
|
●ユーザーフォームを任意の位置に表示したいとき
|
|
ユーザーフォームを任意の位置に表示する場合は、まずユーザーフォームのStartUpPositionプロパティを0（手動）に設定します。
そのあとでTopとLeftプロパティに任意の座標を指定します。
設定は下の例のようにＶＢＡで設定するか、または直接プロパティウィンドから設定してもかまいません。
Public Sub CallMenu()
With UserForm1
.StartUpPosition = 0
.Top = 100
.Left = 23
.Show
End With
End Sub
|
|
|
●拡張子を特定してファイル一覧を取得したいとき
|
|
フォルダ内のファイル一覧を取得する方法についてはネット上にたくさん紹介されていますが、一番シンプルな方法を掲載しておきます。
サブフォルダも含めた一覧取得となると、かなり難しくなってきます（プロシージャの再帰呼出し等）ので他サイトで調べてください。
サンプルはマクロブックが置かれたフォルダにあるエクセルブックの一覧を取得できます。
Public Sub GetFileList()
Dim myDir As String
Dim i As Long
'出力先ワークシートをクリア
Cells.ClearContents
'拡張子xlsのファイル一覧を取得する
myDir = Dir(ThisWorkbook.Path & "\" & "*.xls", vbNormal)
Do While myDir <> ""
i = i + 1
Cells(i, 1).Value = myDir
myDir = Dir()
Loop
End Sub
|
|
|
●InputBox関数で押されたボタンを識別したいとき
|
|
InputBox関数で押されたボタンによる処理の分岐は、初心者にとって案外難しいものです。
ここではＶＢＡの非表示メンバStrPtr関数を使って判定しています。
Public Sub InputCheck()
Dim rs As String
rs = InputBox("データを入力してください")
If StrPtr(rs) = 0 Then
MsgBox "「キャンセル」ボタンが押されました"
Exit Sub
Else
MsgBox "「ＯＫ」ボタンが押されました"
End If
End Sub
|
|
|
●InputBox関数で文字のみ入力を可能としたいとき
|
|
入力された値が文字か数字かを判断するにはIsNumeric関数を使うと簡単です。
数字の場合はTrueが返されるので、Falseのときだけループを抜けるようにします。
キャンセルボタンが押されたとき、または何も入力しないでOKボタンを押したときは処理を中止します。
逆に数値のみの入力を判定するならば、InputBoxメソッドの方が便利かもしれません。
Public Sub GetOnlyChar()
Dim rs As String
Do
rs = InputBox("文字のみ入力してください")
If rs = "" Then Exit Sub
Loop While IsNumeric(rs)
MsgBox rs & "が入力されました。"
End Sub
Public Sub GetOnlyNum()
Dim RS As Long
RS = Application.InputBox(prompt:="数値を入力してね", Type:=1)
End Sub
|
|
|
●特定文字列を含むBook名からその正式Book名を取得したいとき
|
|
あるフォルダ内の特定の文字列を含むブック名を検索して、その正式ブック名を取得する関数です。
CURRENTPATH定数にはあらかじめ現在の検索対象となっているパスが定義されているものとします。
関数GetFileNameFullに検索文字列を渡すと、該当するブックを探し出してその正式ブック名を文字列で返します。
ただし該当するブックが複数あっても、最初に見つかったブックの名前を返すだけですので、複数のブック名を取得させるためには各自で工夫してください。
Public Function GetFileNameFull(kw As String) As String
Dim myDir As String
Dim ps As Integer
myDir = Dir(CURRENTPATH & "\" & "*.xls", vbNormal)
Do While myDir <> ""
ps = InStr(1, myDir, kw, vbTextCompare)
If ps > 0 Then
'ファイル名を取得
GetFileNameFull = myDir
Exit Function
End If
myDir = Dir()
Loop
'NG
GetFileNameFull = ""
End Function
|
|
|
●計算式が入ったセル以外をクリアしたいとき
|
|
値のみ（計算式が入ったセル以外）をクリアしたいときのサンプルです。
マクロを実行する前に、クリアしたい範囲を選択しておいてください。
マクロを実行すると、値のみが消去されます。
セルに計算式が埋め込まれているかどうかは、①ではHasFormulaプロパティで判断します。
②ではSpecialCellsメソッドの最初の引数にxlCellTypeConstants（定数）を指定します。
Public Sub ClearValue1()
'①１つずつセルをクリア
Dim C As Range
For Each C In Selection
If Not C.HasFormula Then
C.ClearContents
End If
Next C
End Sub
Public Sub ClearValue2()
'②SpecialCellsメソッドで一括クリア
Selection.SpecialCells(xlCellTypeConstants, _
xlTextValues + xlNumbers).ClearContents
End Sub
|
|
|
●タイトルの年度表示を変更したいとき
|
|
複数のワークシートにタイトルがあり、そのタイトルの一部に年度表示がされている場合、その年度をすべてのワークシートに対して変更していくのは結構面倒ですね。
このサンプルは、ワークシートのF1にタイトルの先頭が“平成１８年度 各支店別売上実績…”などになっていて、その年度部分の数字のみを変更するときの例です。
ここでInputBox関数に入力する年度は、半角でも全角でもすべて全角に直されて書き込まれるようにしています。
Public Sub ChangeNendo()
Dim rs As String
Dim c() As String
Dim i As Integer
Dim j As Integer
Dim strTitle As String
Dim strNewTitle As String
Dim Lrs As String
rs = InputBox("新しい年度（数字）を入力してください")
Lrs = StrConv(rs, vbWide) '全角に変換
If StrPtr(Lrs) = 0 Then
'キャンセル
Exit Sub
Else
'変更処理
For j = 1 To ActiveWorkbook.Worksheets.Count
Worksheets(j).Activate
If InStr(1, ActiveSheet.Name, "月") Then
strTitle = ActiveSheet.Range("F1").Value
ReDim c(Len(strTitle)) As String
'タイトルを1文字単位に分解する
For i = 0 To Len(strTitle)
c(i) = Mid(strTitle, i + 1, 1)
Next i
'年度を置換
c(2) = Mid(Lrs, 1, 1)
c(3) = Mid(Lrs, 2, 1)
'タイトルを書き戻す
strNewTitle = ""
For i = 0 To Len(strTitle)
strNewTitle = strNewTitle & c(i)
Next i
ActiveSheet.Range("F1").Value = strNewTitle
End If
Next j
End If
End Sub
|
|
|
●指定したアドレスから列名を取り出す
|
|
アクティブセルの列数がわかっていて、それを列名に変換したいときどうしますか？
列数と列名のテーブルを作っておき、参照するのもいいですが手間がかかりますね。
sampleのコードはネット上にあったものですが、知っていると非常に便利なコードだと思います。
Split関数を使うと文字列をelimiterで指定した記号で分割して、配列として返してくれます。
その配列から特定要素を指定すると、希望の値が取り出せます。
sampleではSelection.Addressで"$A$1"のような文字列が取得できますので、それを"$"で分割することにより、"","A","1"の3つの要素が返ってきます。
そのうちの要素1を指定することにより（配列の要素は0から始まります）、列名を取得できるようになっています。
これが使いづらいならば、自分でGetColName関数のようなものを作ってしまうのもいいでしょう。
GetColName関数に現在選択しているセルのアドレスを引数として渡すと、列名だけが返ってきます。
Sub sample()
MsgBox Split(Selection.Address, "$")(1)
End Sub
Public Function GetColName(c As String) As String
Dim ar
ar = Split(c, "$")
GetColName = ar(1)
End Function
Public Sub test()
MsgBox GetColName(Selection.Address)
End Sub
|
|
|
●特殊フォルダのパスを取得したいとき
|
|
特殊なフォルダはパソコンによって、あるいはWindowsによって場所がまちまちです。
そんなときそのパスを取得する方法を知っていれば便利ですね。
サンプル1では、デスクトップとマイドキュメントのパスを知ることができます。
サンプル2では、Windowsのセットアップ場所、システムフォルダ、一時フォルダのパスを取得できます。
Public Sub GetSpecialFolder_1()
'特殊フォルダのパスを取得_1
Dim ws
Set ws = CreateObject("WScript.Shell")
MsgBox "Desktop= " & ws.SpecialFolders("Desktop")
MsgBox "MyDocuments= " & ws.SpecialFolders("MyDocuments")
End Sub
Public Sub GetSpecialFolder_2()
'特殊フォルダのパスを取得_2
Dim FSO
Dim OBJ
Set FSO = CreateObject("Scripting.FileSystemObject")
Set OBJ = FSO.GetSpecialFolder(0)
MsgBox "setup= " & OBJ.Path
Set OBJ = FSO.GetSpecialFolder(1)
MsgBox "system= " & OBJ.Path
Set OBJ = FSO.GetSpecialFolder(2)
MsgBox "temporary= " & OBJ.Path
End Sub
|
|
|
●連続したセル範囲の値を配列に格納したいとき
|
|
連続した範囲のセルの値を配列に格納する場合は、配列をバリアント型(Variant)で変数を定義しておくのがミソです。
変数はデータ格納後は配列として操作できるようになります。
注意しておくことは、作成される配列は1次元配列ではなくて、配列名(1,1)から始まる2次元配列になるということです。
これはワークシートが行・列からなる2次元のシートなので想像できると思います。
格納データのサンプル
Public Sub SetToArray()
Dim ar As Variant
ar = Range("A1:E1").Value
'B1の値を表示
MsgBox ar(1, 2)
'B2の値を表示
ar = Range("A1:E2").Value
MsgBox ar(2, 2)
End Sub
|
|
|
●VBAにファンクションキーを認識させたいとき
|
|
ユーザーフォームを表示してデータ入力などを行わせたいとき、キーボードから手を離してマウスで終了ボタンを押してもらうのは無駄な時間が発生してしまいます。
できればキーボードのみで終了操作をしてもらう方が効率がよいでしょう。
そういう場合にファンクションキーを使って終了処理ができないものでしょうか。
サンプルではフォームにテキストボックスが配置されており、そこにフォーカスが当たっている場合にF12キーを押されたことをVBAに認識させる例を示しています。
テキストボックスが複数置かれている場合は、そのすべてに同様の記述をすることで、どのタイミングでもファンクションキーを認識させることができます。
逆にいうとすべてのテキストボックスに記述しないと、意図した動作にならないかもしれません。
ExcelのVBAではユーザーフォームのKeyDownイベントに記述してもファンクションキーを認識してくれません。
「フォームは、コントロールが1つもないか、または表示されているすべてのコントロールが選択不可能に設定されている場合に限り、フォーカスを持つことができる」ためです。
Private Sub TextBox1_KeyDown(ByVal KeyCode As
MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyF12 Then
MsgBox "F12が押されたよ。"
End If
End Sub
|
|
|
●多次元配列で各配列要素の上限を求めたいとき
|
|
１次元配列でしたら配列要素の上限はUBound(配列名)で求まることはご存知だと思います。
For～Next文などで配列の要素を1つづつ取り出して処理する際にループカウンタの上限値として使用します。
ところで多次元配列の場合はどうするのでしょうか？
この場合、UBound(配列名)とすると１番目の配列要素の上限は取得できますが、２番目以降は取得できません。
ところがUBound(配列名, 要素番号)とすることで簡単に２番目以降の配列要素の上限も求まります。
Public Sub test()
'多次元配列で各配列要素の上限を求める
Dim aa(1 To 5, 1 To 3)
MsgBox UBound(aa) '5を返す
MsgBox UBound(aa, 1) '5を返す
MsgBox UBound(aa, 2) '3を返す
End Sub
|
|
|
●必ず指定したセルが画面の左上隅に表示されるようにしたいとき
|
|
例えばSheet1を表示したら必ずセルK1が画面の左上にくるようにしたい、そういう場合のコードです。
オペレータに余分なスクロール動作をさせたくない場合などに利用できます。
Worksheets("Sheet1").Activate
Application.Goto Reference:=Range("$K$1"), Scroll:=True
|
|
|
●ユーザーフォームを画面いっぱいいに表示したいとき
|
|
ユーザーフォームを表示する際にExcelのワークシートを見えないようにしたい場合に便利です。
ユーザーフォームのInitializeイベントに下記のコードを記入してください。
イベントの初期値はClickイベントになっていますので、必ずイベントの変更を行ってからコーディングしてください。
フォームを呼び出すと、画面いっぱいにフォームが表示されます。
「×」（クローズ）ボタンを無効にしていると、閉じるときに困りますので、実行の際には「閉じる」ボタンを設けておくとよいでしょう。
Application.Width : アプリケーション ウィンドウ（ここではExcelウィンドウ）の左端から右端までの距離を返します。
Application.Height : アプリケーション ウィンドウ（ここではExcelウィンドウ）の上端から下端までの距離を返します。
Private Sub UserForm_Initialize()
Me.Width = Application.Width
Me.Height = Application.Height
End Sub
|
|
|
●名前を付けて保存ダイアログを表示したいとき
|
|
先頭の引数でデフォルトのファイル名を表示します。省略は可能です。
この引数を省略すると、作業中のブックの名前が使われます。
キーワードはInitialFilenameです。
2番目はファイルの候補を指定する文字列 (ファイル フィルタ文字列) を指定します。
キーワードはFileFilterです。
3番目は飛ばして4番目はダイアログ ボックスのタイトルを指定します。
キーワードはTitleです。
この引数を省略すると、"名前を付けて保存" になります。
Public Sub SaveBook()
Dim myBook As Variant
'「名前を付けて保存」ダイアログ
myBook = Application.GetSaveAsFilename("test.xls", _
"Excelファイル,*.xls", , "Excelブックを保存")
'キャンセル時の処理
If StrConv(myBook, vbUpperCase) = "FALSE" Then Exit Sub
'ブックの保存
ActiveWorkbook.SaveAs Filename:=myBook
End Sub
|
|
|
●選択（クリック）した行に色を付けたいとき
|
|
任意のセルを選択（クリック）したときに、その行全体に色を付けるマクロです。
コードを記述する場所に注意してください。
ワークシートのSelectionChangeイベントを利用します。（標準モジュールではありません）
色を変更した後で、また他のセルをクリックした場合、前の変更した行の色を元に戻しています。
こうすることで、たくさんのデータの中で現在注視している行がはっきり分かり、データを見失うことを防げて便利です。
Private m_ROW As Long '変更前の行番号
Private m_IRO As Long '変更前の色
Private Const MYCOLOR As Long = 36 '変更する色番号
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'選択した行に色を付ける
If Target.Row > 1 Then '2行目以降を対象とする
'変更前の色に戻す
If m_ROW <> 0 Then
Rows(m_ROW).Interior.ColorIndex = m_IRO
End If
'変更前の行番号と色を記憶
m_ROW = Target.Row
m_IRO = Rows(Target.Row).Interior.ColorIndex
'色を変更
Rows(Target.Row).Interior.ColorIndex = MYCOLOR
End If
End Sub
|
|
|
●フォルダ参照ダイアログでパスを取得したいとき
|
|
フォルダ参照ダイアログを使って、選択したフォルダのパスを取得するコードです。
最も一般的に使われているかもしれません。
関数になっているので、使用するときは「変数=GetFolder()」のようにして使います。
Public Function GetFolder() As String
'ダイアログを開いて、選択フォルダのパスを返す
Dim WSH
Dim FolPath
Dim strGuide As String
strGuide = "フォルダを指定してください。"
Set WSH = CreateObject("Shell.Application")
Set FolPath = WSH.BrowseForFolder(0, strGuide, 0)
If Not FolPath Is Nothing Then
'[OK]
GetFolder = FolPath.items.Item.Path
Else
'[Cancel]
GetFolder = ""
End If
End Function
|
|
|
●1月1日から数えて指定日が第何週目かを知りたいとき
|
|
ワークシートのセル番地A1に調べたい日付が入っているものとします。
DatePart関数を利用すると、様々な時間間隔を調べることができます。
【構文】
DatePart(interval, date[,firstdayofweek[, firstweekofyear]])
interval：必須。時間間隔の単位を指定。
date：必須。日付を指定。
firstdayofweek：週の始まりの曜日を表す定数を指定。デフォルト値はvbSunday（日曜日）。
firstweekofyear：年度の第1週を表す定数を指定。デフォルト値はvbFirstJan1（1月1日を含む週を第1週）。
■intervalの設定値
yyyy：年
q：四半期
m：月
y：年間通算日
d：日
w：週日
ww：週
h：時
n：分
s：秒
■firstdayofweekの設定値
vbUseSystem：0 NLS API の設定値を使います。
vbSunday：1 (既定値) 日曜
vbMonday：2 月曜
vbTuesday：3 火曜
vbWednesday：4 水曜
vbThursday：5 木曜
vbFriday：6 金曜
vbSaturday：7 土曜
■firstweekofyearの設定値
vbUseSystem：0 NLS API の設定値を使います。
vbFirstJan1：1 (既定値) 1月1日を含む週を年度の第1週とする。
vbFirstFourDays：2 7日のうち少なくとも4日が新年度に含まれる週を年度の第1週として扱う。
vbFirstFullWeek：3 全体が新年度に含まれる最初の週を年度の第1週として扱う。
Public Sub test()
Dim myDate As Date
myDate = Cells(1, 1).Value
MsgBox "1月1日を含む週を第1週目として数えた場合、" & myDate & "は第" _
& DatePart("ww", myDate) & "週目です。"
End Sub
|
|
|
●ユーザーフォームにハイパーリンクを設定したいとき
|
|
ワークシートと同じようにユーザーフォームにもハイパーリンクを設定する方法です。
ネット上のウェブサイトにリンクを張る方法は、他の場所でも紹介されているようですが、ワークシートにリンクを張る例があまり見当たらなかったので記しておきます。
次のサンプルではSheet1のA100セルにリンクを張っています。
ユーザーフォーム上にラベル１を配置し、クリックイベントに記述します。
ただし、ラベル上にマウスがあってもポインタは指マークには変化しません！
Private Sub Label1_Click()
'ワークシート上のセルにリンク
ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Path _
& "\" & ThisWorkbook.Name, SubAddress:="Sheet1!A100"
End Sub
|
|
|
●生年月日から年齢を計算したいとき
|
|
生年月日から年齢を計算するときは、DateDiff関数を使うのが便利でしょう。
注意しなければいけないのは、そのまま使うと結果が満年齢では返ってこない点です。
誕生日前であっても誕生日が過ぎたものとして年齢が計算されてしまいます。
このため、ここでは誕生日の月日と基準日の月日とを比較して、基準日が誕生日の前になっている場合は１を引いています。
サンプルでは基準日が誕生日と同じ日ですので、8が返ります。
仮に誕生日が"1999/07/02"だと、7が返ることになります。
もちろん基準日は今日の日付にすることもできます。
DateDiff関数の引数の与え方については、VBAのヘルプを参照してください。
Public Sub nenrei()
Dim birth As String
Const KIJUN As String = "2007/07/01"
birth = "1999/07/01"
If Format(birth, "mm/dd") > Format(KIJUN, "mm/dd") Then
Range("A1").Value = DateDiff("yyyy", birth, KIJUN) - 1
Else
Range("A1").Value = DateDiff("yyyy", birth, KIJUN)
End If
End Sub
|
|
|
●OnActionプロパティを使って、実行マクロに引数を渡したいとき
|
|
OnActionプロパティを使うと、オブジェクトがクリックされたときに実行するマクロを設定できますが、同時に引数も渡したいときがあります。
例えば挿入した画像をクリックしたときに、その画像のオブジェクト名をいっしょに渡したい
（Selection.OnAction = "Macro1" & オブジェクト名 としたい…）場合です。
引数がリテラル（プログラムの中に直接記述できる値のこと、定数）の場合は、例えば次のように記述すれば動きます。
【例１】 Selection.OnAction = "'Macro1 ""ABC""'"（Macro1にABCを渡す）
では変数を渡したい場合はどうすればよいでしょうか？
これは私も試行錯誤の上探し当てたのですが、【例２】のようにすれば問題なく動きました。
もっと簡潔にしたかったのですが、分かりませんでした。
今のところ自分では一応これでOKということにしています。
【例２】Selection.OnAction = "'Macro1 " & """" & 変数 & """" & "'"
|
|
|
●セルサイズに画像のサイズを合わせたいとき
|
|
画像をシートに挿入するマクロと組み合わせて使うと便利です。
下記のプロシージャは画像サイズをセルの幅または高さに合わせるマクロのサンプルです。
ここでは拡大・縮小の際に常にセル内に画像が納まるように、高さと幅の比を計算し、長さが小さい方にサイズを合わせるようにしています。
また、デフォルトで設定されているようですが、Selection.ShapeRange.LockAspectRatio = msoTrueを明示して、拡大・縮小時に高さと幅の比率が常に一定になるようにしています。
Public Sub SetPicSize()
Dim Cell_H As Single
Dim Cell_W As Single
Dim Cell_Ratio As Single
Dim Obj_Ratio As Single
'セルの幅と高さを取得
With Range("A1")
Cell_H = .Height
Cell_W = .Width
Cell_Ratio = .Height / .Width '高さ／幅
End With
'画像をセルの幅または高さに合わせる
ActiveSheet.Shapes("Picture 1").Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue '一定比率
Obj_Ratio = .Height / .Width
If Cell_Ratio > Obj_Ratio Then
'セル枠の方が高さの比が大きい（セル幅に合わせる）
.Width = Cell_W
Else
'セル枠の方が高さの比が小さい（セル高に合わせる）
.Height = Cell_H
End If
End With
End Sub
|
|
|
●配列を初期化したいとき
|
|
配列をプログラムの途中で0や""で初期化する場合、For～Nextで値を代入する方法と、Eraseステートメントでクリアする方法があります。
Eraseステートメントについては、VBAのヘルプに詳しく説明されていますので、以下にそれをそのまま掲載しておきます。
Eraseステートメントは固定サイズの配列の場合は要素を再初期化し、動的配列の場合は割り当てたメモリを解放します。
Eraseの横には、消去する配列変数を指定し、複数指定する場合は、カンマ (,) で区切ります。
配列が固定サイズの配列 (通常の配列) であるか、または動的配列であるかによって、Erase ステートメントの動作は異なります。
固定サイズの配列の場合、Erase ステートメントはメモリを解放せずに各要素を次のように設定します。
静的数値配列 →要素はすべて0に設定
静的文字列配列 (可変長) →要素はすべて長さ0の文字列("")に設定
静的文字列配列 (固定長) →要素はすべて0に設定
静的バリアント型 (Variant) 配列 →要素はすべてEmpty値に設定
ユーザー定義型配列 →各要素は、別個の変数として設定
オブジェクト配列 →要素はすべて特別な値Nothingに設定
動的配列の場合はその配列が使っていたメモリを解放します。
そのためプログラムでこの配列を再度参照するには、ReDim ステートメントを使って、配列の次元を再宣言する必要があります。
例1)
For i=0 to UBound(ar)
ar(i)=0
Next i
例2)
Erase ar
|
|
|
●ファイルのコピーと削除をVBAで実行したいとき
|
|
VBAでファイルをコピーしたり、削除したりする例です。
ここではテキストファイルのみに対して操作可能にしています。
ときにはコピー先のファイル名を変更したい場合もあるかもしれません。目的に合わせてアレンジしてみてください。
なおファイルコピーは、コピー先に同名のファイルが存在する場合は、そのままコピー元の内容で上書きされてしまいますので注意してください。
SelectedFileCopy及びSelectedFileDeleteを、ワークシートにボタンを貼り付けるなどして呼び出せば実行可能です。
Public Sub SelectedFileCopy()
'フィルのコピー
Dim sFrom As String
Dim sTo As String
Dim msg As String
Dim tmp As String
'コピー元指定
msg = "コピー元ファイルを指定してください"
sFrom = Application.GetOpenFilename("テキストファイル,*.txt", , msg)
If StrConv(sFrom, vbUpperCase) = "FALSE" Then
MsgBox "キャンセルされました。"
Exit Sub
End If
'ファイル名を取り出す
tmp = NameFromPath(sFrom)
'コピー先指定
msg = "コピー先フォルダを指定してください"
sTo = GetFolder(msg)
sTo = sTo & "\" & tmp
'ファイルのコピー
FileCopy sFrom, sTo
MsgBox sFrom & "を" & sTo & "にコピーしました。"
End Sub
Public Sub SelectedFileDelete()
'ファイルの削除
Dim sDell As String
Dim msg As String
'削除ファイル指定
msg = "削除ファイルを指定してください"
sDell = Application.GetOpenFilename("テキストファイル,*.txt", , msg)
If StrConv(sDell, vbUpperCase) = "FALSE" Then
MsgBox "キャンセルされました。"
Exit Sub
End If
'ファイルの削除（ゴミ箱には入らないので注意）
Kill sDell
MsgBox sDell & "を削除しました。"
End Sub
Public Function GetFolder(msg As String) As String
'ダイアログを開いて、選択フォルダのパスを返す
Dim WSH
Dim FolPath
Set WSH = CreateObject("Shell.Application")
Set FolPath = WSH.BrowseForFolder(0, msg, 0)
If Not FolPath Is Nothing Then
'[OK]
GetFolder = FolPath.items.Item.Path
Else
'[Cancel]
GetFolder = ""
End If
End Function
Function NameFromPath(strPath As String) As String
Dim lngPos As Long
Dim strPart As String
Dim blnInclude As Boolean
'ファイルパスかどうかを調る
lngPos = InStrRev(strPath, "\")
blnInclude = InStrRev(strPath, ".") > lngPos
'パスからファイル名部分を取り出す
If lngPos > 0 Then
If blnInclude Then
strPart = Right$(strPath, Len(strPath) - lngPos)
End If
End If
NameFromPath = strPart
End Function
|
|
|
●開いているすべてのフォーム名を取得したいとき
|
|
現在メモリにロードされているすべてのユーザーフォームのキャプションとオブジェクト名を取得して表示するサンプルです。
使い道があるかどうか分かりませんが一応掲載しておきます。
Public Sub GetLdForm()
Dim fm As Object
For Each fm In UserForms
MsgBox fm.Name & vbCrLf & fm.Caption
Next
End Sub
|
|
|
●ワークシートにイベント処理を記述したくないとき
|
|
ワークシート上でクリック、ダブルクリックなどのイベントが発生したときに、ワークシートに直接イベント処理を記述しないで、別モジュールに記述する方法を説明します。
特定ワークシートを単なる資料として保存したいようなときに便利です。
該当シートのみを単独で保存した場合、毎回「マクロを有効にする」かの問合せがなくなるので、わずらわしさが軽減します。
まずThisWorkbookモジュールのWorkbook_Open()イベントに①を記述します。
次に標準モジュールModule1に②を書いてください。
そのまま保存をして再度起動すると、Sheet1のA1・B1・C1をダブルクリックしたときのみ、マクロが実行されます。
Private Sub Workbook_Open()
'①
ActiveWorkbook.Worksheets("Sheet1").OnDoubleClick = "Test"
End Sub
Public Sub Test()
'②
Select Case ActiveCell.Address
Case "$A$1"
MsgBox "A1がダブルクリックされました。"
Case "$B$1"
MsgBox "B1がダブルクリックされました。"
Case "$C$1"
MsgBox "C1がダブルクリックされました。"
End Select
End Sub
|
|
|
●空白を含む文字列からすべての空白を取り除きたいとき
|
|
空白を取り除く関数にTrim()、LTrim()、RTrim()関数がありますが、Trim()関数でも文字列の両端の空白を取り除くことしかできません。
文字列の中に含まれる空白（半角、全角）を取り除くために作ったものが以下のコードです。
単純ですが便利です。
Public Function SpaceOff(dt As String) As String
Dim tmp As String
Dim Aftr As String
Dim i As Integer
For i = 1 To Len(dt)
tmp = Mid(dt, i, 1)
If tmp <> " " And tmp <> " " Then
Aftr = Aftr & tmp
End If
Next i
SpaceOff = Aftr
End Function
|
|
|
●一定間隔でマクロを実行させたいとき
|
|
一定間隔でマクロを実行させる場合は、次の記述が有効かもしれません。
当然マクロで何をさせるのかによって、有効な場合とそうでない場合があると思いますので、使用する際は注意してください。
次の例は10秒間隔でセルに現在時刻の表示を更新させるものです。
このような類の場合は、便利だと思います。
まずマクロ起動時に、現在から10秒後にプロシージャ"Proc1"を実行せよとのコードを記述します。
OnTimeメソッドは、指定された時刻にプロシージャを実行する命令です。
現在の時刻から指定時間が過ぎてから、処理を実行させたいときは、後ろにNow + TimeValue(time) と付加します。
指定した特定の時刻に処理を実行させるときは、TimeValue(time) を使います。
例 9時にProc1を実行：Application.OnTime TimeValue("09:00:00"), "Proc1"
いったんProc1が実行されると、Proc1の処理の中で再び自分自身を呼び出す「Application.OnTime Now + TimeValue("00:00:10"), "Proc1"」の記述があるため、再帰的に無限に繰り返されることになります。
または単純に一定間隔でループを行わせるだけなら、Waitメソッドを使ったほうがよいかもしれません。②参照
①
Private Sub Proc1()
Range("A1") = Format(Now, "hh:mm:ss")
'(メインの処理を記述／例：セルに時刻表示)
' 次の処理の起動準備をする
Application.OnTime Now + TimeValue("00:00:10"), "Proc1"
End Sub
Private Sub auto_open()
'開始時に10秒後の起動設定を行う
Application.OnTime Now + TimeValue("00:00:10"), "Proc1"
End Sub
②単純にループを一定間隔で実行する場合
Public Sub sample()
Dim i As Long
Dim strT As String
'待ち時間を秒で指定
strT = Format(Range("B1").Value, "00")
'指定間隔でA1にカウント表示
For i = 9 To 0 Step -1
Range("A1").Value = i
Application.Wait Now + TimeValue("00:00:" & strT)
DoEvents '省略するとループ実行の間は操作を受け付けなくなります
Next i
End Sub
|
|
|
●ワークシート関数と同等のRound 関数を使用したいとき
|
|
マイクロソフトサイトに「VBAのRound 関数は、Excelワークシート関数のRoundと異なる結果となる場合があります。」との記述があります。
具体的には、ワークシート関数のRound は"算術型" （通常の四捨五入）の丸め処理を行いますが、VBAのRound関数は"銀行型" の丸め処理を行い、".5" は、結果が偶数になるように丸め処理が行われ、切り上げられることも、切り捨てられることもありえます。
したがってワークシート関数と同じ機能のRound 関数を使用したい場合は、次のようにWorksheetFunctionプロパティを使用するのがよいようです。
以下の例では、①の式ではxに8が格納されますが、②ではxに9が格納されます。
y = 8.5
x = Round(y, 0) '①
MsgBox x
x = Application.WorksheetFunction.Round(y ,0) '②
MsgBox x
|
|
|
●値貼り付けを簡潔にコーディングしたいとき
|
|
ある範囲のデータを値貼り付けでコピー＆ペーストする場合、“形式を選択して貼り付け”で“値”を選択すると、マクロ記録では【１】のコードが作成されます。
このままでも再実行できますが、簡潔、高速にするためSelectメソッドをはずすされる方も多いと思います。【２】値貼り付けでなければ1行にまとめることも出来ます。
さらに【３】のようにcopyメソッドを使わずに、範囲をバリアント型変数に格納し、そのままコピー先の場所に代入すると、選択範囲を解除する必要もなくなります。
【１】
Sub Macro1()
Range("A1:A10").Select
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
【２】※値貼り付けでなければ
Range("A1:A10").Copy Sheets("Sheet2").Range("C1") がよいでしょう。
Sub Macro2()
Range("A1:A10").Copy
Sheets("Sheet2").Range("C1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
【３】
Public Sub copytest()
Dim ar As Variant
ar = Range("A1:A10").Value
Worksheets("Sheet2").Range("C1:C10").Value = ar
End Sub
|
|
|
●オブジェクトのセル番地を取得したいとき
|
|
この場合はTopLeftCellプロパティを使用します。
下記はワークシート上にコマンドボタンやチェックボックスなどのオブジェクトを配置したとき、そのオブジェクトをクリックした際、配置下のセル番地を取得する場合のコード例です。
複数のセルにまたがって配置した場合には、オブジェクトの左上端のアドレスとなります。
ただしコントロールツールボックスで配置したオブジェクトに限ります。
フォームオブジェクトでは機能しません。
Private Sub CommandButton1_Click()
MsgBox CommandButton1.TopLeftCell.Row
MsgBox CommandButton1.TopLeftCell.Column
MsgBox CommandButton1.TopLeftCell.Address
End Sub
|
|
|
●シートに保護がかかっているかどうか調べたいとき
|
|
現在のワークシートに保護がかかっているかどうかは、WorksheetのProtectContentsプロパティで判定することが可能です。
Trueが返って来たら、シートの内容は保護されていることになります。
Public Sub CheckProtect()
'シート保護の識別
If ActiveSheet.ProtectContents Then
MsgBox "シート保護されています。"
Else
MsgBox "シート保護されていません。"
End If
End Sub
|
|
|
●スクロールエリアを制限したいとき
|
|
例はセル番地B2からJ43以外の場所へのスクロールを制限します。
セル選択もできなくなります。
解除する場合はScrollAreaプロパティに空の文字列 ("") を設定します。
Worksheets("Sheet1").ScrollArea="B2:J43" または
Worksheets(1).ScrollArea="B2:J43"
|
|
|
●押されたボタンの名前を取得したいとき
|
|
フォームツールバーで作成したボタンを押したときの、そのボタン名を取得するためのコードです。
サンプルを応用すれば似たようなボタンが複数あるとき、ボタン名をパラメータとしてプロシージャに渡してあげることで共通の処理をさせることができます。
次のサンプルはExcelメニューバーから「表示」→「ツールバー」→「フォーム」でワークシート上にボタンを作成し、マクロの登録で標準モジュール上に作成した「DspBunntonName」に関連付けた場合、押されたボタン名を表示します。
Public Sub DspBunntonName()
'押されたボタンの名前を表示
MsgBox Application.Caller
End Sub
|
|
|
●複数オブジェクトを選択したいとき
|
|
ワークシート上に複数配置されたオートシェイプのうち、任意のものを選択する方法です。
手作業ではコントロールキーを押しながら１つずつ選択していくか、マウスで範囲をドラッグして一挙に選択する操作に該当します。
Selectメソッドでオブジェクトを選択し直す場合は後ろに true（省略可）、現在の選択内容に既に選択されているオブジェクトを追加する場合は false を記述します。
Sub SelectObj_1()
'複数オブジェクトの選択例１
With ActiveSheet
.Shapes("Rectangle 1").Select
.Shapes("Rectangle 2").Select False
.Shapes("Rectangle 3").Select False
End With
End Sub
Public Sub SelectObj_2()
'複数オブジェクトの選択例２
ActiveSheet.Shapes.Range(Array("Rectangle 1", _
"Rectangle 2", _
"Rectangle 3")). _
Select
End Sub
|
|
|
●ワークシートのオブジェクト名を調べたいとき
|
|
ワークシートのシート名ではなく、コード名（オブジェクト名）を知るにはCodeNameプロパティを調べます。
CodeNameプロパティはオブジェクトのコード名を返します。
また、シート名を調べる場合はNameプロパティを調べます。
シートの作成時はシート名とコード名は同じですが、シート名とコード名は別な名前に変更できるので、そういう場合はこれらプロパティで調べるとそれぞれの名前が分かります。
MsgBox "オブジェクト名= " & ActiveSheet.CodeName
MsgBox "シート名= " & ActiveSheet.Name
|
|
|
●入力後のセル移動を変更したいとき
|
|
以下は、ワークシートによって、入力後のセルポインタの移動方向を変更する場合のサンプルです。
シートが選択されたとき、Sheet1の場合は右へ移動するように変更し、Sheet1以外は下への移動に戻ります。（シート名で判定する場合はNameプロパティで比較してください）
サンプルではワークブックを閉じたときに、BeforeCloseイベントで必ず下への移動に戻るようにしていますが、通常の移動方向を「下へ」以外にしている場合はその状態に戻してください。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'入力後のセル移動を[下へ]に変更
With Application
.MoveAfterReturn = True
.MoveAfterReturnDirection = xlDown
End With
End Sub
Private Sub Workbook_Open()
Sheet1.Activate
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'WorkSheetのオブジェクト名を判定
If Sh.CodeName = "Sheet1" Then
'入力後のセル移動を[右へ]に変更
With Application
.MoveAfterReturn = True
.MoveAfterReturnDirection = xlToRight
End With
Else
'入力後のセル移動を[下へ]に変更
With Application
.MoveAfterReturn = True
.MoveAfterReturnDirection = xlDown
End With
End If
End Sub
|
|
|
●フォルダ内のファイル名をリスト表示
|
|
次のサンプルは、マクロが置かれているフォルダ内のファイル一覧を、リストボックスに表示するコードです。
ファイルの拡張子「.xls」のみをリストボックスに追加していきます。
自身のファイル名は不要なので、ThisWorkbook.Nameで名前を確認してはずすようにしています。
Dir()ではパスを除いたファイル名だけが帰ってくるので便利です。
Dim buf As String
buf = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
Do While buf <> ""
If buf <> ThisWorkbook.Name Then
ListBox1.AddItem buf
End If
buf = Dir()
Loop
|
|
|
●レベル制御（小計の出力）を行いたいとき
|
|
コード（A列）の先頭1文字が変わったら、そこまでの小計を出力するサンプルです。
下図のデータ（A列～B列）を集計し、D、E列に書き出します。
Public Sub sample()
Dim i As Long '入力行
Dim j As Long '出力行
Dim sCode As String
Dim ttl As Variant
Dim sum_ttl As Variant
Dim endRow As Long
'データをA列でソート
endRow = Range("A65536").End(xlUp).Row
Range("A1:B" & endRow).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=True
Range("A1").Select
'集計列をクリア
Range("D1:E65536").ClearContents
'集計処理
i = 1: j = 1
sCode = Left(Cells(i, 1).Value, 1)
Do While Cells(i, 1).Value <> ""
If sCode <> Left(Cells(i, 1).Value, 1) Then
'小計出力
Cells(j, 4).Value = "-- 小計 --"
Cells(j, 5).Value = ttl
ttl = 0
j = j + 2
End If
'明細出力
Cells(j, 4).Value = Cells(i, 1).Value
Cells(j, 5).Value = Cells(i, 2).Value
ttl = ttl + Cells(i, 2).Value
sum_ttl = sum_ttl + Cells(i, 2).Value
sCode = Left(Cells(i, 1).Value, 1)
i = i + 1
j = j + 1
Loop
'最後グループの小計出力
Cells(j, 4).Value = "-- 小計 --"
Cells(j, 5).Value = ttl
j = j + 2
'総計出力
Cells(j, 4).Value = "-- 総計 --"
Cells(j, 5).Value = sum_ttl
End Sub
|
|
|
●一時的にプリンタを変更する
|
|
VBAから今印刷しようとしている出力先プリンタを変更する場合の例です。
ActivePrinterで印刷しようとするプリンタ名を指定します。
ネットワーク上のプリンタを使用していたり、他のパソコンに接続されているプリンタを使用している場合などで、ポート番号が変化するために印刷がうまく実行されない場合は、プリンタ名後半の「on NeXX:」部分を削除して指定してください。
なお変更したままでは後の操作に支障がでるような場合は、マクロ起動時に現在のプリンタ名を取得しておき、印刷後に元にもどしておきます。
Public DefaultPrinter As String
Public Sub Print()
'一時的にプリンタを変更する
ActiveSheet.PrintOut _
Copies:=1, _
ActivePrinter:="Canon BJ S300 on Ne03:", _
Collate:=True
'デフォルトプリンタに戻す
Application.ActivePrinter = DefaultPrinter
End Sub
Private Sub Workbook_Open()
'現在のプリンタ名を記憶
DefaultPrinter = Application.ActivePrinter
End Sub
|
|
|
●ファンクションキーに任意のマクロを割り当てたいとき
|
|
F1,F2,F3...のようなファンクションキーに任意のプロシージャ／関数を割り当てると、メニューからマクロを実行したり、ボタンを設置したりしなくて済むので便利かもしれません。
ただし普段マウスでの操作しかしないのであれば、かえって不便かもしれません。
そのときの使用状況に合わせて考えてみてください。
VBAコードはいたって簡単です。
標準モジュールにあらかじめ"test1"や"test2"などのプロシージャを作成しておき、ファイル起動時にF1やF2キーに、Application.OnKeyメソッドでそれぞれのプロシージャを割り当てておきます。
Private Sub Workbook_Open()
Application.OnKey "{F1}", "test1"
Application.OnKey "{F2}", "test2"
End Sub
|
|
|
●固定長レコードを読み込みたいとき
|
|
読み込むファイルが固定長データの場合、各項目の長さが決まっているため、
読み込んだデータを各項目の長さで切り分けて、それをセルまたは変数に格納する
方法を取ります。
データを各項目の長さごとに分割する場合、まずMid関数（またはMid$関数）を利用する方法を思いつきますが、
文字単位で位置をカウントする場合、全角、半角が混じったデータだとうまくいきません。
そこでMidB関数（またはMidB$関数）を使って、バイト単位でカウントすることにします。
ここで注意しなければならないのがVBAはUnicodeを採用しているので、文字コードが16ビット（2バイト）単位であることです。
つまり例え日本語文字が1文字であっても、Unicodeでは2バイトで表現されていることになります。
このままだと位置や長さの計算が不便なので、いったんANSIコード（1文字＝8ビット／1バイト）に変換して、処理後にUnicodeに戻す処理を行わせています。
'【レコード内の各項目の位置（長さ）】
' 1-16(16) :名前
'17-36(20) :読み
'37-44(08) :生年月日
'45-45(01) :性別
'------------------------------------
Sub ReadData()
Dim FSO As Object 'FileSystemObject
Dim TSO As Object 'TextStream
Dim inREC As String 'データ
Dim FilePath As String 'ファイルパス
Dim r As Long '出力行
Const DATA_FILE As String = "\fxData.txt"
FilePath = ThisWorkbook.Path & DATA_FILE
Set FSO = CreateObject("Scripting.FileSystemObject")
r = 1
Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
With TSO
Do Until .AtEndOfStream
inREC = StrConv(.ReadLine, vbFromUnicode)
Cells(r, 1).Value = StrConv(MidB$(inREC, 1, 16), vbUnicode)
Cells(r, 2).Value = StrConv(MidB$(inREC, 17, 20), vbUnicode)
Cells(r, 3).Value = StrConv(MidB$(inREC, 37, 8), vbUnicode)
Cells(r, 4).Value = StrConv(MidB$(inREC, 45, 1), vbUnicode)
r = r + 1
Loop
.Close
End With
End Sub
|
|
|
●選択したオブジェクトのみを処理する
|
|
ワークシート上の全オブジェクトについて、何か処理する場合は①のようにFor Eachでまわしてやればできますが、
選択したオブジェクトだけに対して何か処理したい場合は、なかなかうまい方法が見つかりません。
ここでは②のようにしてTypeNameを実行したときに返ってくる値を利用して判定しています。
例えばシートに貼り付けてある画像を1個選択している場合は"Picture"が返りますが、2個以上を選択している場合は
"DrawingObjects"が返ります。このことを利用してIF文で処理を分岐させています。
Public Sub ①全オブジェクトを処理()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
MsgBox shp.Name
Next shp
End Sub
Public Sub ②選択オブジェクトを処理()
Dim obj As Object
If TypeName(Selection) = "Picture" Then
MsgBox "選択されているオブジェクト名は" & Selection.Name, , "1枚選択"
ElseIf TypeName(Selection) = "DrawingObjects" Then
For Each obj In ActiveSheet.DrawingObjects
MsgBox "選択されているオブジェクト名は" & obj.Name, , "複数選択"
Next obj
Else
MsgBox "画像を選択してください。", , "選択なし"
End If
End Sub
|
|
|
●自作のメンバーリストを作成して、定数を入力する
|
|
あることに関係する一連の定数がたくさんあったとします。それを個々にConstステートメントで宣言してもよいですが、定数を列挙型で宣言すると、入力する際にメンバーリストからの入力ができて楽です。
それがEnumステートメントを使った宣言方法です。（ただし長整数型のみです）
下記の例は、あまり意味のあるコードではありませんが、利用方法を示すために載せています。
Option Explicit
Public Enum pCube
pC_Tate = 10
pc_Yoko = 15
pc_Takasa = 7
End Enum
Public Sub Sample()
Dim cb1 As pCube
Dim cb2 As pCube
Dim cb3 As pCube
Dim myVolume As Long
cb1 = pc_Takasa
cb2 = pC_Tate
cb3 = pc_Yoko
myVolume = cb1 * cb2 * cb3
MsgBox myVolume
End Sub
|
|
|
●セル値を文字列と数字に分離する
|
|
１つのセルに文字列と数字が混ざって入力されているとき、それを文字列と数字に分けなければいけないことは、ときどきあります。
何かのコードのような場合は、それぞれの桁数があらかじめ決まっており、位置も固定なのでそれほど苦労せずに分離できると思います。
しかし、中にはランダムに文字列と数字のかたまりが入力されており、とにかくその文字列と番号（数字）を分けなくてはいけないことがあるかもしれません。
そのようなとき、次のマクロは役に立つと思います。
Public Sub 文字と数字に分割()
Dim Letter(5) As String
Dim Number(5) As String
Dim i As Long
Call LMSplit(Letter, Number)
For i = 0 To UBound(Letter)
If Letter(i) = "" Then Exit For
Debug.Print Letter(i)
Next i
For i = 0 To UBound(Number)
If Number(i) = "" Then Exit For
Debug.Print Number(i)
Next i
End Sub
|
|
Public Sub LMSplit(Letter() As String, Number() As String)
'文字/数字分割マクロ
Dim i As Long
Dim j As Long
Dim k As Long
Dim myData As String
Dim xx As String
Dim LetBuf As String
Dim NumBuf As String
Dim bNum As Boolean
myData = Range("A1").Value
For i = 1 To Len(myData)
xx = Mid(myData, i, 1)
If xx Like "[0-9]" Then
'数字
If Not bNum And i > 1 Then
Letter(k) = LetBuf
LetBuf = ""
k = k + 1
End If
NumBuf = NumBuf & xx
bNum = True
Else
'文字
If bNum Then
Number(j) = NumBuf
NumBuf = ""
j = j + 1
End If
LetBuf = LetBuf & xx
bNum = False
End If
Next i
'Last
If LetBuf <> "" Then
Letter(k) = LetBuf
End If
If NumBuf <> "" Then
Number(j) = NumBuf
End If
End Sub
|
|
|
