トップ   新規 一覧 単語検索   ヘルプ   最終更新のRSS

Excel VBA(仮) のバックアップソース(No.1)

#contents
**デザインパタン [#u8652b6a]
***セルに名前をつけてRange指定 [#rdf6611a]
-列の増加、行の増加などで固定したいセル番地が変更することは多々ある。
-''セルに名前をつけて指定すると列、行の増減影響を受けない。''
-Range("B3")のセルに"cellName"という名前をつける。
-セルの名前のつけ方は[[こちら:http://shower.human.waseda.ac.jp/~m-kouki/pukiwiki_public/index.php?Excel%20Tips#r2516707]]を参照。
   '----------------------------------------------------------------
   ' 名前をつけたセルを指定する
   '----------------------------------------------------------------
    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(列挙型)を使用してセル指定 [#l1aaadb2]
#ref(enumMethod1.JPG)
 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利用) [#sbfd5701]
-メッセージゲット関数にメッセージ引数(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

**セル [#bc2c7109]
***名前の定義によって設定されたセル名取得方法 [#q107d485]
-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
***全選択 [#j75bc875]
-別ブックを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
**ファイル入出力 [#y8ed961b]
***FileSystemObjectプロパティ・メソッド [#ebc644c1]
-[[よくまとまっているサイト:http://officetanaka.net/excel/vba/filesystemobject/filesystemobject.htm]] 

***ファイル入力 [#z820f871]
-フォルダ指定
--フォルダ配下のファイルを取得する(サブフォルダのファイルは含まない)
     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

---[[ログ出力-s_setLogについて:http://shower.human.waseda.ac.jp/~m-kouki/pukiwiki_public/index.php?Excel%20VBA%20%E8%87%AA%E4%BD%9C%E9%96%A2%E6%95%B0#lf5597fa]]
---[[メッセージゲット-f_getAlrtMessage(infoAlrt.NotFoundFile)について:http://shower.human.waseda.ac.jp/~m-kouki/pukiwiki_public/index.php?Excel%20VBA%28%E4%BB%AE%29#sbfd5701]]

***ファイル名操作 [#u5124993]
-取得したファイル名から拡張子なしの純粋なファイル名のみ取得
--オブジェクト: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

***ファイル書き込み [#s9dc6ec3]
-テキストファイル書込
    '-----------------------------------------
    'ファイル書き込み
    '-----------------------------------------
    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

**関数 [#rbb4aea8]
***Chr関数 [#qee29d1d]
[[Excel VBA 自作関数]]
-Chr(9):タブ
-Chr(10):ラインフィード
-Chr(13):キャリッジリターン

***IsNumeric(数字/文字判定)関数 [#sf02a028]
-String型でも中身が数字であればTrueを返す。
-IsNumeric(判定したい数字/文字)
 if(IsNumeric("2.3") = true )then
    MsgBox "数字と判定します"
 End if

#ref(checkNumber.PNG)

***IIf関数 [#x7710003]
-評価式を評価するとき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(Function_IIf.PNG)

**メモ [#m0564673]
***[[VBAでピボットテーブル作成:http://pvttbl.blog23.fc2.com/blog-entry-8.html]] [#kd66f011]
***シート削除 [#e72a41ec]
-グラフを含むシート削除。
-Worksheets("シートの名前").Delete はだめ
-Sheets("シートの名前").Delete はOK
-[[As String * length:http://www.geocities.jp/cbc_vbnet/kisuhen/statement.html]]