Excel VBA(仮) のバックアップ(No.1)
デザインパタン †
セルに名前をつけてRange指定 †
- 列の増加、行の増加などで固定したいセル番地が変更することは多々ある。
- セルに名前をつけて指定すると列、行の増減影響を受けない。
- Range("B3")のセルに"cellName"という名前をつける。
- セルの名前のつけ方はこちらを参照。
'---------------------------------------------------------------- ' 名前をつけたセルを指定する '---------------------------------------------------------------- Sub cellName() '同じセルを指定 Sheet1.Range("B3").Value = "名前をつけたセル" Sheet1.Range("cellName").Value = "名前をつけたセル" End Sub
- A列とB列の間に列を挿入した場合、Sheet1.Range("cellName")ではRange("C3")を指し、
- Sheet1.Range("B3")ではRange("B3")を指すこととなる。
ただVBAのコードでセル名管理ができないため、シート参照してセル名を把握しなければならないところが難点。
Enum(列挙型)を使用してセル指定 †
#ref(): File not found: "enumMethod1.JPG" at page "Excel VBA(仮)"
Public Enum enumOCR ID = 0 ' ID InventoryBillNo = 1 ' ID InventoryDate = 2 ' 棚札番号 PlantCode = 3 ' 棚札年月日 StorageCode = 4 ' プラント CustomerCode = 5 ' 保管場所 CustomerItemCode = 6 ' 得意先コード ItemCode = 7 ' 得意先品目コード BookStock = 8 ' 品目コード End Enum
メッセージgetter(Enum利用) †
- メッセージゲット関数にメッセージ引数(Enumで定義)を渡しメッセージを取得する
- メイン処理(メッセージ関数を呼び出す)
'------------------------------------------------------------- ' main '------------------------------------------------------------- Sub main() '処理を開始, 処理開始メッセージを取得 Msgbox f_getInfoMessage(infoMsg.StartPrg) End Sub
- メイン処理(メッセージ関数を呼び出す)
- メッセージ関数 渡された引数と一致するメッセージを返す
'------------------------------------------------------------- ' 情報メッセージ設定(getter) '------------------------------------------------------------- Function f_getInfoMessage(msgNo) Select Case msgNo Case Is = infoMsg.StartPrg f_getInfoMessage = "処理を開始します" Case Is = infoMsg.CancelFileSelect f_getInfoMessage = "ファイル読み込みを中止します" End Select End Function
- Enum設定
'------------------------------------------------------------- ' 設定 '------------------------------------------------------------- Enum infoMsg StartPrg = 0 '処理開始メッセージ CancelFileSelect = 1 'ファイル読み込みキャンセルメッセージ End Enum
セル †
名前の定義によって設定されたセル名取得方法 †
- mainからセル名を取得する関数を呼び出す。
- 構文:Range("B3").Name.Name
'---------------------------------------------------------------- ' セルにつけた名前を取得 '---------------------------------------------------------------- Sub main() Debug.Print getCellName(Sheet1.Range("B3")) Debug.Print getCellName(Sheet2.Range("B3")) 'error Debug.Print getCellNameErr(Range("B3")) Debug.Print getCellNameErr(Range("B3")) End Sub '---------------------------------------------------------------- ' セルにつけた名前を取得 '---------------------------------------------------------------- Function getCellName(targetCell As Range) getCellName = targetCell.Name.Name End Function
- Range型の引数にシートを指定するとエラーとなる。
'---------------------------------------------------------------- ' セルにつけた名前を取得エラー(シート名+Range) ' コンパイルエラー:メソッド名またはデータメンバが見つかりません '---------------------------------------------------------------- Function getCellNameErr(targetCell As Range) getCellNameErr = Sheet1.targetCell.Name.Name getCellNameErr = Worksheets(1).targetCell.Name.Name End Function
全選択 †
- 別ブックをOpen後、全選択。元のブックのシートに値貼り付け。
Dim strFilePassName As String Dim thisBook As Workbook Dim wbInputData As Workbook 'このブック(マクロのブック)を取得 Set thisBook = ThisWorkbook 'ファイルオープン(エクセルのみオープン可) OpenFileName = Application.GetOpenFilename("Microsoft ExcelƒuƒbƒN,*.xls") If OpenFileName <> "False" Then Set wbInputData = Workbooks.Open(strFilePassName) End If 'シート1を全選択→コピー wbInputData.Sheets(1).Cells.Copy '元ブックをアクティベイト thisBook.Activate 'RangeのPasteSpecialを利用し値貼り付け Sheet4.Range("A1").PasteSpecial Paste:=xlPasteValues ’ブックをクローズ workBook1.Close
ファイル入出力 †
FileSystemObjectプロパティ・メソッド †
ファイル入力 †
- フォルダ指定
- フォルダ配下のファイルを取得する(サブフォルダのファイルは含まない)
With Application.FileDialog(msoFileDialogFolderPicker) 'ダイアログタイトル名 .Title = "入力ファイル用フォルダ選択" 'フォルダを選択し開くボタンがクリックされた If .Show = True Then strFoldPass = .SelectedItems(1) 'キャンセルボタンがクリックされた Else GoTo AlrtHandler End If End With '先頭のファイル名の取得 strFileName = Dir(strFoldPass & cnsDIR, vbNormal) Set FSO = CreateObject("Scripting.FileSystemObject") 'フォルダ配下にファイルがない(エラーハンドリング) If (strFileName = "") Then GoTo AlrtHandler2 'フォルダ配下にファイルがある Else 'ファイルが見つからなくなるまでLoop Do While strFileName <> "" ReDim Preserve vAllFileName(iCntFileNo) '拡張子あり vAllFileName(iCntFileNo) = strFileName iCntFileNo = iCntFileNo + 1 '次のファイル名を取得する strFileName = Dir() Loop End If ExitHandler: Exit Function AlrtHandler: 'ログ出力 Call s_setLog(f_getInfoMessage(infoMsg.CancelFileSelect)) MsgBox f_getInfoMessage(infoMsg.CancelFileSelect) '異常終了 f_getFileName = True GoTo ExitHandler AlrtHandler2: 'ログ出力 Call s_setLog(f_getAlrtMessage(infoAlrt.NotFoundFile)) '異常終了 f_getFileName = True GoTo ExitHandler
- フォルダ配下のファイルを取得する(サブフォルダのファイルは含まない)
ファイル名操作 †
- 取得したファイル名から拡張子なしの純粋なファイル名のみ取得
- オブジェクト:FileSystemObject
- メソッド名:GetBaseName
- パスを引数に渡す
- 存在しないフォルダ&ファイル名でも拡張子なしのファイル名を返す
- ファイル名.拡張子を引数に渡しても純粋ファイル名のみを返す
Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") 'Book1を返す FSO.GetBaseName("C:\Work\Book1.xls") 'Book1を返す FSO.GetBaseName("Book1.xls") Set FSO = Nothing
ファイル書き込み †
- テキストファイル書込
'----------------------------------------- 'ファイル書き込み '----------------------------------------- Function f_writeFile(ByVal strFoldPass, ByVal vOutPut) Dim iFileNo As Integer Dim vLoop As Variant On Error GoTo ErrHandler 'FreeFile関数 iFileNo = FreeFile 'ファイル名判定 '既にファイルが存在している場合→既存ファイルオープン 'ファイルなしの場合→新規ファイル作成 If (strOutputFileName = "") Then 'ファイル名作成 strOutputFileName = Format(Now, "YYYYMMDD_HHNNSS_") & f_getOutPutFileName & ".txt" Open strOutputFileName For Output As #iFileNo Else Open strOutputFileName For Append As #iFileNo End If For Each vLoop In vOutPut Print #iFileNo, vLoop Next vLoop Close iFileNo '正常終了 f_writeFile = False ExitHandler: Exit Function ErrHandler: '実行時エラー intRet = systemErr(Err.Number, Err.Description, "f_writeFile") '異常終了 f_writeFile = True GoTo ExitHandler End Function
関数 †
Chr関数 †
Excel VBA 自作関数?
- Chr(9):タブ
- Chr(10):ラインフィード
- Chr(13):キャリッジリターン
IsNumeric(数字/文字判定)関数 †
- String型でも中身が数字であればTrueを返す。
- IsNumeric(判定したい数字/文字)
if(IsNumeric("2.3") = true )then MsgBox "数字と判定します" End if
#ref(): File not found: "checkNumber.PNG" at page "Excel VBA(仮)"
IIf関数 †
- 評価式を評価するときTrueのとき返す値、Falseのとき返す値、両方の引数を評価する。 そのためどちらかの引数でエラーが発生する場合、IIf関数はエラーになる。
- IIf(判定式,Trueのとき返す値or式,Falseのとき返す値or式)
Sub test_IIf() Dim strHairType As String strHairType = "Long" 'IIf判定式 Debug.Print IIf(strHairType = "Short", "Boyish", "Girlsh") End Sub
#ref(): File not found: "Function_IIf.PNG" at page "Excel VBA(仮)"
メモ †
VBAでピボットテーブル作成 †
シート削除 †
- グラフを含むシート削除。
- Worksheets("シートの名前").Delete はだめ
- Sheets("シートの名前").Delete はOK
- As String * length