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

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