自動画像配置

今回は、指定したフォルダーのJPGファイルをEXCELシートに自動配置するプログラムです。
マニュアル作成に、威力を発揮するのではないでしょうか？

下図は、実行した結果できたEXCELシートです。



Public Sub 自動画像配置()
  On Error Resume Next
  Dim Rtn As Integer, i As Integer, j As Integer, f As Integer, wPos As Integer
  Dim wFiles() As String
  Dim wFile As String, wPath As String, wNewFile As String
  Rtn = MsgBox("自動画像配置を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'フォルダー選択
  wFile = InputFolder("画像ファイルのあるフォルダーを選択", , , , "マイ コンピュータ")
  If wFile = "" Or wFile = "False" Then
     Application.StatusBar = "処理をキャンセルしました。"
     Exit Sub
  Else
     wPath = wFile
  End If
  'ファイル名の入力
  wFile = InputBox("EXCEL出力ファイル名を入力して下さい。", "自動画像配置", "自動画像配置")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '新しいシート（ブック）を追加する
  Sheets.Add
  Cells.Select
  Range("A13").Activate
  Selection.ColumnWidth = 2
  '文字書式を設定する
  Selection.NumberFormatLocal = "@"
  'ふぉるだー配下のJPGファイルを取得する
  Call GetFiles(wPath, "*.jpg", wFiles())
  i = 1
  j = 0
  '該当ファイル
  For f = 0 To UBound(wFiles)
      '項番挿入
      j = j + 1
      Range("A" & i).Select
      ActiveCell.FormulaR1C1 = j
      Range("B" & i).Select
      ActiveCell.FormulaR1C1 = "ＸＸＸＸＸＸ"
      '図形挿入
      Range("B" & i + 4).Select
      ActiveSheet.Pictures.Insert(wFiles(f)).Select
      Selection.ShapeRange.ScaleWidth 0.59, msoFalse, msoScaleFromTopLeft
      Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
      '項番挿入
      j = j + 1
      Range("A" & i + 32).Select
      ActiveCell.FormulaR1C1 = j
      Range("B" & i + 32).Select
      ActiveCell.FormulaR1C1 = "ＸＸＸＸＸＸ"
      '図形挿入
      f = f + 1
      Range("B" & i + 36).Select
      ActiveSheet.Pictures.Insert(wFiles(f)).Select
      Selection.ShapeRange.ScaleWidth 0.59, msoFalse, msoScaleFromTopLeft
      Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
      ActiveWindow.LargeScroll ToRight:=-1
      '改頁
      i = i + 64
      Range("A" & i).Select
      ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Next
  wPath = ActiveWorkbook.Path
  Sheets("自動画像配置").Select
  Sheets("自動画像配置").Copy
  Sheets("自動画像配置").Select
  Sheets("自動画像配置").Name = wFile
  ActiveSheet.PageSetup.PrintArea = ""
  With ActiveSheet.PageSetup
      .LeftHeader = ""
      .CenterHeader = "&A"
      .RightHeader = ""
      .LeftFooter = ""
      .CenterFooter = "&P/&N"
      .RightFooter = ""
      .LeftMargin = Application.InchesToPoints(0.62992125984252)
      .RightMargin = Application.InchesToPoints(0.196850393700787)
      .TopMargin = Application.InchesToPoints(0.669291338582677)
      .BottomMargin = Application.InchesToPoints(0.275590551181102)
      .HeaderMargin = Application.InchesToPoints(0.433070866141732)
      .FooterMargin = Application.InchesToPoints(0.196850393700787)
      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .PrintQuality = 600
      .CenterHorizontally = False
      .CenterVertically = False
      .Orientation = xlPortrait
      .Draft = False
      .PaperSize = xlPaperA4
      .FirstPageNumber = xlAutomatic
      .Order = xlDownThenOver
      .BlackAndWhite = False
      .Zoom = 98
      .FitToPagesWide = 1
      .FitToPagesTall = False
  End With
  wNewFile = ActiveWorkbook.Name
  '現在のシートをファイル保存
  Workbooks(wNewFile).SaveAs Filename:=wPath & "\" & wFile & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
  Workbooks(wFile & ".xls").Close
  Sheets("自動画像配置").Select
  ActiveWindow.SelectedSheets.Delete
  Sheets("雛形").Select
  Sheets("雛形").Name = "自動画像配置"
  Sheets("自動画像配置").Select
  Sheets("自動画像配置").Copy After:=Sheets(1)
  Sheets("自動画像配置 (2)").Select
  Sheets("自動画像配置 (2)").Name = "雛形"
  Sheets("自動画像配置").Select
  ActiveWorkbook.SaveAs
  Workbooks.Open Filename:=wPath & "\" & wFile & ".xls"
  Application.StatusBar = "自動画像配置処理が終了しました。"
  Application.DisplayAlerts = True
End Sub

ところで、ナンデモ動画サイト EcoTubeというサイトを見つけたのですが、このサイト、結構、お勧めです。

それでは！

フォルダ名の選択ウィンドウ

今回は、フォルダ名の選択ウィンドウを表示する方法を紹介しますが、少々、上級編になっています。

何故かというと、元々EXCELの機能にはないので、Windows APIといのを使用するからです。

Windows APIというのは、Windowsシステムのあらゆる機能が定義されている低レベルなサブルーチンの集まりです。
低レベルというのは、いわゆる、レベルが低いという意味ではなく、Windwosの基本的な機能を提供するという意味で捉えて下さい。

ですから、EXCELにない機能も実現できちゃたりするのです！
今回は、フォルダ名の選択ウィンドウを表示するのですが、複数のWindowsAPIを利用するので、結構、分かり辛いと思います。

Option Explicit

'InputFolder用
Private Const MAX_PATH            As Long = 260
Private Const BFFM_SETSTATUSTEXTA As Long = &H464&  ' ステータステキスト
Private Const BFFM_ENABLEOK       As Long = &H465&  ' OK ボタンの使用可否
Private Const BFFM_SETSELECTIONA  As Long = &H466&  ' アイテムを選択
Private Const BFFM_INITIALIZED    As Long = &H1&
Private Const BFFM_SELCHANGED     As Long = &H2&
Private Type RECT
        left As Long    'WindowのX座標
        top As Long     'WindowのY座標
        right As Long   'Windowの右端の座標
        bottom As Long  'Windowの底にあたる部分の座標
End Type
Private Type BROWSEINFO
    hWndOwner       As Long     'ダイアログの親ウィンドウのハンドル
    pidlRoot        As Long     'ディレクトリツリーのルート
    pszDisplayName  As String   'MAX_PATH
    lpszTitle       As String   'ダイアログの説明文
    ulFlags         As Long     'ENUM_FLAGS_FOLDER
    lpfn            As Long     'コールバック関数へのポインタ
    lParam          As String   'コールバック関数へのパラメータ
    iImage          As Long     'フォルダーアイコンのシステムイメージリスト
End Type

Public Enum ENUM_ROOT_FOLDER
    CSIDL_DESKTOP = &H0&                        ' デスクトップ
    CSIDL_INTERNET = &H1&                       ' インターネット
    CSIDL_PROGRAMS = &H2&                       ' Program Files
    CSIDL_CONTROLS = &H3&                       ' コントロールパネル
    CSIDL_PRINTERS = &H4&                       ' プリンタ
    CSIDL_PERSONAL = &H5&                       ' ドキュメントフォルダー
    CSIDL_FAVORITES = &H6&                      ' お気に入り
    CSIDL_STARTUP = &H7&                        ' スタートアップ
    CSIDL_RECENT = &H8&                         ' 最近使ったファイル
    CSIDL_SENDTO = &H9&                         ' 送る
    CSIDL_BITBUCKET = &HA&                      ' ごみ箱
    CSIDL_STARTMENU = &HB&                      ' スタートメニュー
    CSIDL_DESKTOPDIRECTORY = &H10&              ' デスクトップフォルダー
    CSIDL_DRIVES = &H11&                        ' マイコンピュータ
    CSIDL_NETWORK = &H12&                       ' ネットワーク(ネットワーク全体あり)
    CSIDL_NETHOOD = &H13&                       ' NETHOOD フォルダー
    CSIDL_FONTS = &H14&                         ' フォント
    CSIDL_TEMPLATES = &H15&                     ' テンプレート
    CSIDL_COMMON_STARTMENU = &H16&              '
    CSIDL_COMMON_PROGRAMS = &H17&               '
    CSIDL_COMMON_STARTUP = &H18&                '
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19&       '
    CSIDL_APPDATA = &H1A&                       '
    CSIDL_PRINTHOOD = &H1B&                     '
    CSIDL_ALTSTARTUP = &H1D&                    '
    CSIDL_COMMON_ALTSTARTUP = &H1E&             '
    CSIDL_COMMON_FAVORITES = &H1F&              '
    CSIDL_INTERNET_CACHE = &H20&                '
    CSIDL_COOKIES = &H21&                       '
    CSIDL_HISTORY = &H22&                       '
End Enum
Enum ENUM_FLAGS_FOLDER
    BIF_RETURNONLYFSDIRS = &H1&          ' フォルダのみ
    BIF_DONTGOBELOWDOMAIN = &H2&         ' ネットワークコンピューターを非表示
    BIF_STATUSTEXT = &H4&                ' ステータス表示
    BIF_RETURNFSANCESTORS = &H8&
    BIF_BROWSEFORCOMPUTER = &H1000&      ' ネットワークコンピューターのみ
    BIF_BROWSEFORPRINTER = &H2000&       ' プリンターのみ
    BIF_BROWSEINCLUDEFILES = &H4000&     ' 全て選択可能
End Enum

Private Declare Function SHBrowseForFolder Lib "shell32" (ByRef lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHFree Lib "shell32" Alias "#195" (ByVal pidl As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Public Function InputFolder( _
    Optional ByRef strTitle As String = "フォルダーを選択してください", _
    Optional ByVal lngOwnerHwnd As Long = 0&, _
    Optional ByVal lngRoot As ENUM_ROOT_FOLDER = CSIDL_DESKTOP, _
    Optional ByVal lngFlags As ENUM_FLAGS_FOLDER = BIF_RETURNONLYFSDIRS, _
    Optional ByRef strParam As String = vbNullString) As String

    On Error GoTo Err_InputFolder:

    Dim biParam     As BROWSEINFO
    Dim pidl        As Long
    Dim strPath     As String

    If lngOwnerHwnd = 0& Then
        lngOwnerHwnd = GetDesktopWindow()
    End If

    strPath = String$(MAX_PATH, vbNullChar)

    With biParam
        .hWndOwner = lngOwnerHwnd
        .pidlRoot = lngRoot
        .pszDisplayName = strPath
        .lpszTitle = strTitle & vbNullChar
        .ulFlags = lngFlags
        If Len(strParam) > 0& Then
            
            .lpfn = GetLong(AddressOf BrowseCallbackProc)
            .lParam = strParam & vbNullChar
        End If
    End With

    pidl = SHBrowseForFolder(biParam)

    If biParam.ulFlags And BIF_BROWSEFORCOMPUTER Then
        strPath = biParam.pszDisplayName
        strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
    Else
        If pidl = 0& Then
            strPath = vbNullString
        Else
            If SHGetPathFromIDList(pidl, strPath) <> 0& Then
                strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
            Else
                strPath = vbNullString
            End If
        End If
    End If

    Call SHFree(pidl)
    InputFolder = strPath
Exit_InputFolder:
    Exit Function

Err_InputFolder:
    InputFolder = vbNullString
    Resume Exit_InputFolder:
End Function

'
'   SHBrowseForFolder API のコールバック関数。
'
Private Function BrowseCallbackProc(ByVal lngHWnd As Long, ByVal lngUMsg As Long, _
                            ByVal lngLParam As Long, ByVal lngLpData As String) As Long
    Select Case lngUMsg
        Case BFFM_INITIALIZED
            Call SendMessageStr(lngHWnd, BFFM_SETSELECTIONA, 1&, StrConv(lngLpData, vbUnicode))
        'Case BFFM_SELCHANGED
        ' ITEMが選択された時に処理を行いたい場合ここに書きます
    End Select
    BrowseCallbackProc = 0&
End Function

Private Function GetLong(varAddr As Variant) As Long
    GetLong = CLng(varAddr)
End Function

フォルダ名の選択ウィンドウを表示するGetFolderNameの使用方法は、次回、紹介します。

それでは！

ファイル一覧取得

今日は、あるフォルダー配下のサブフォルダーも含めたファイル一覧を取得します。

今回は、サブルーチンからサブルーチンを呼んでいます。
又、サブルーチンが自分自身を呼んでいますが、これを再帰呼び出しと呼びますが、これにより、プログラムが単純化され、行数も少なくてすみます。

GetFilesサブルーチンには、フォルダー名とファイルパターン（例では、EXCELファイルだけを取得する為に、*.xlsとしています）を指定すると、その条件に合致したファイル名一覧をシートの11行目以降に表示します。

Public Sub ファイル一覧取得()
  On Error Resume Next
  Dim wFiles() As String
  Dim i As Integer
  Dim wFolder As String
  wFolder = "C:\Documents and Settings\azukei\My Documents\EXCELツール"
  'ファイル一覧取得サブルーチンを呼ぶ
  Call GetFiles(wFolder, "*.xls", wFiles())
  '13行目以降を選択する
  Range(Cells(13, 1), ActiveCell.SpecialCells(xlLastCell)).Select
  '選択したエリアをクリアする
  Selection.ClearContents
  '11行目1列目にフォルダー名をセットする
  Cells(11, 1) = wFolder
  '13行目より、取得したファイル名をセットする
  For i = 0 To UBound(wFiles)
      Cells(i + 13, 1) = wFiles(i)
  Next
  Cells(1, 1).Select
End Sub

Public Sub GetFiles(ByVal pFolder As String, ByVal pPattern As String, ByRef pFiles() As String)
  On Error Resume Next
  Dim i As Integer
  Dim wFile As String
  Dim wSubFolder As String
  '配列（pFiles）の最大インデックスを取得する
  i = UBound(pFiles)
  'フォルダー内の最初のファイルを取得する
  wFile = Dir(pFolder & "\" & pPattern, vbNormal)
  Do Until wFile = ""
     '配列の要素数を動的に変更する
     ReDim Preserve pFiles(i)
     pFiles(i) = pFolder & "\" & wFile
     i = i + 1
     'フォルダー内の次のファイルを取得する
     wFile = Dir
  Loop
  'フォルダー内の最初のサブフォルダーを取得する
  wSubFolder = Dir(pFolder, vbDirectory)
  Do Until wFile = ""
     '自分自身のサブルーチンを呼ぶ（再帰呼び出し）
     Call GetFiles(wSubFolder, pPattern, pFiles())
     'フォルダー内の次のサブフォルダーを取得する
     wSubFolder = Dir
  Loop
End Sub

今日はここまで！

それでは！

ファイル行数集計

今日は、ファイルの行数集計です。

非常にシンプルなサブルーチンです。

Public Sub 行数集計()
  Dim Rtn As Integer
  Dim wFNo As Integer
  Dim wCnt As Integer
  Dim wRec As String
  '実行確認メッセージ
  Rtn = MsgBox("行数集計を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  wCnt = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     'ファイルから1行読み込む
     Line Input #wFNo, wRec
     wCnt = wCnt + 1
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox wCnt & "行ありました。", vbInformation + vbOKOnly
End Sub

それでは！

CSVファイル入力 その２

今回は、もう一つのCSVファイル入力方法です。

前回は、Line Input文で、1行分読み込んでから処理しましたが、今回は、Input文を使用して、カンマで区切られた内容を1項目づつ取り出すやり方です。
今回のやり方は、予め1行に何項目あるかが分かっている場合に使えますね！

Public Sub CSV入力2()
  Dim Rtn As Integer
  Dim i As Integer
  Dim j As Integer
  Dim wFNo As Integer
  Dim wCell(3) As String
  '実行確認メッセージ
  Rtn = MsgBox("CSV入力を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  i = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     i = i + 1
     '1行をカンマ区切りで、1項目づつ入力する
     Input #wFNo, wCell(1), wCell(2), wCell(3)
     For j = 1 To 3
         Cells(i, j) = Replace(wCell(j), Chr$(34), "")
     Next
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox "CSV入力が終了しました。", vbInformation + vbOKOnly
End Sub

それでは！

CSVファイル入力

今回は、CSVファイルを呼んで、シートに表示するサブルーチンについてです。

EXCELは、CSVファイルをダブルクリックすると、ちゃんと表示してくれますから、この機能はあまり意味がないですね！
CSVファイルの入力方法には、2つありますが、今回は、Line Input文を使って、1行分づつ読み込んでから、カンマで分離して、さらに、ダブルクオーテーションを取り除く方法を紹介します。

Public Sub CSV入力1()
  Dim Rtn As Integer
  Dim i As Integer
  Dim j As Integer
  Dim wFNo As Integer
  Dim wRec As String
  Dim wCell() As String
  '実行確認メッセージ
  Rtn = MsgBox("CSV入力を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  i = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     i = i + 1
     'ファイルから1行読み込む
     Line Input #wFNo, wRec
     'カンマで区切られた内容を分離して、配列にセットする
     wCell = Split(wRec, ",")
     For j = 0 To 2
         'ダブルクオーテーション（Chr$(34)）を空値へ置換する
         wCell(j) = Replace(wCell(j), Chr$(34), "")
         Cells(i, j + 1) = wCell(j)
     Next
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox "CSV入力が終了しました。", vbInformation + vbOKOnly
End Sub

今日は、ここまでです。

次回は、もう一つのCSV入力方法について紹介します。

それでは！

海外ドラマについて

私は、かなり以前から、スカパーで海外ドラマを見ています。

基本的には、先が読めないストーリー性の高い作品が好きですが、中でもSFは発想が自由で、奇想天外なストーリーが多いです。

以前は、スタートレックシリーズが好きでしたが、最近では、スターゲイトやLostが気に入っています。

スタートレックは、スタートレック、新スタートレック、スタートレック・DS9、スタートレック・ボイジャー、スタートレック・エンタープライズと5シリーズもあり、全部あわせると数百話あります。
そのうちのほとんどの作品を見ていて、又、再放送も何度も見ているので、最近は少々、飽きてきています。

スターゲイトは、シーズン10まであって、世界最長ドラマになっていますが、スピンアウト作品であるスターゲイト・アトランティスもシーズン3まであります。
両作品とも、質が高く、特撮やストーリ性が抜群で、これも、再放送を何度も見ています。

Lostは、上記作品とは違って、舞台は地球上の現代なのですが、飛行機が南の孤島に墜落して、生き残った人達と島の不思議な力との葛藤を描く、ミステリアスな作品ですが、これも、再放送を何度見ています。
やっと、7月からLost5が始まりますが、今度、頻繁にタイムスリップが起きるみたいです。

私にとって、良いドラマとは、何度も再放送を見ても大丈夫な作品ということになります。

みなさんは、如何でしょうか？

それでは！

PCの話

皆さんは、どんなPCを使用していますか？

デスクトップですか？ノートPCですか

私の自宅には、デスクトップ3台（1台故障）、ノート4台（1台故障）と、家族4人に対して、人数分以上あります。

最近まで、デュアルコアのデスクトップを使用していましたが、音と電気代が気になりだして、オークションでノートPCを2万円台で入手して、使用しています。

昔のノートPCは、壊れやすく高かったのですが、今はそんな事はありません。
SPECは、PentiumMの1.6GHｚでメモリは512KBだったのを、数千円で中古の2GBメモリに乗せ変えました。

今まで使っていたデスクトップよりも、性能は落ちますが、音が静かで、電気もあまり使っていない感じがして、エコな気分です。

私は、PC上でいろいろな事をしているので、かなりハードな使い方をしていますが、上記のSPECでほとんど問題ありません。
OSはXPのSP3ですが、Vistaにすると、かなり遅くなるでしょうね！

でも、もうすぐ発売になるWindows7は、見た目はVistaに近いですが、かなり早くなっているみたいです。デスクトップマシーンにベータ版をインストールをして、動かしてみたのですが、かなり、早く感じました。

ですから、家族の誰かがPCが欲しいといったら、ショップにいって、十万円以上のPCを買っては駄目です。
中古でいいなら、結構性能のいいノートPCが、高くても3万円で手に入ります。
運が良ければ、2万円台で手に入ります。

今日は、ここまで！

マクロ記録について

今回は、マクロ記録について、書きたいと思います。

マクロ記録は、メニューバーのツール→マクロ→新しいマクロの記録で、マクロ名（規定値はmacro1）を入力して、OKボタンを押すと、始まります。



記録終了ボタンを押すと、それまでの、マクロ記録された内容が、VBAのソースとして、標準モジュールに、サブルーチンとして、記録されます。

例えば、シート上で、罫線を引く事をマクロ記録した場合、下記のようなサブルーチンが作成されました。

Sub Macro2()
'
' Macro2 Macro
' マクロ記録日 : 2007/3/2  ユーザー名 : azuma-keiichi
'
    'A1セル～C8セルを選択
    Range("A1:C8").Select
    '選択しているセルに対して、罫線なしにする
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    '選択しているセルに対して、左罫線をセットする
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous     'ラインスタイル
        .Weight = xlThin              '太さ
        .ColorIndex = xlAutomatic     '色
    End With
    '選択しているセルに対して、上罫線をセットする
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、下罫線をセットする
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、右罫線をセットする
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、水平罫線をセットする
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、垂直罫線をセットする
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

コメントは私が、付加したのですが、これを一々コーディングするのは、結構大変ですね！
だから、マクロ記録をうまく使いたいのですが、このままだと、プログラミングし難い事があります。

マクロ記録で一番気をつけなければいけないのは、セルを表す命令がCellsではなく、Rangeになる事です。Cellsは、i行目のj列目という指定ができるのですが、Rangeは、A列の8行目のような指定の仕方をします。Range("A1:C8").Selectのように、列方向の指定が数字ではなく、英字なのです。

これでは、プログラムし難いですよね！

ですから、マクロ記録したソースを使用する場合、Rangeの部分は、Cellsに置き換える必要があります。又、当然、iとかjとかの変数ではなく、定数で展開されますので、その部分も変換します。

基本的には、注意事項はそれだけです。

EXCEマクロ（VBA）には、豊富な機能に対する命令が沢山用意されていますが、マクロ記録をうまく利用すれば、難しそうな事も、結構、簡単に実現できていまします。

この辺が、他の言語と違う所で、私が一番気に入っている所です。

それでは！

ウィルスチェックについて

皆さん、ウィルスチェックはどうされていますか？

私は、最近は、KingSoftの無料セキュリティソフトを使用しています。

このソフト、無料ですが、かなり高機能でいて、結構、軽いです。
また、頻繁にパッチデータやソフトの更新もありますが、自動でやってくれます。
時々、右下に広告ポップアップが表示されるので、そのポップアップを閉じるのが面倒といえば面倒ですが！

市販のソフトは、ちゃんと買っても、期限が切れると更新料を払わないといけなくなるし、以前、買ったソフトなんかは、正規版なのに、最初から使えない状態になってしまった事があり、それ以来、ウィルスチェックソフトを買う気になれません。

以前は別の無料ソフトを使用していましたが、外国製だったのと、イマイチ、機能や性能に不安がありましたが、このKingSoftの無料セキュリティソフトは、安心感があります。

この間、Windows Server 2003にもインストールしてみましたが、警告メッセージは表示されるものの、無事インストールできました。

今まで、サーバーにインストールできるウィルスチェックソフトはなかったので、かなり、お勧めです。

みなさん、まだ、期限付きの有料ソフトを使用しますか？

それでは！

CSVファイル出力

今回は、シートのデータをCSVファイルへ出力します。

CSVとは、カンマ・セパレート・バリューの略で、データをカンマで区切る形式の事で、構造が簡単なので、広く用いられています。

EXCELは、ファイル保存する時に、CSV形式で出力する事ができるので、このプログラムは、あまり、意味がないですね！

詳しくは、ソースとコメントを見てね！

Public Sub CSV出力()
  Dim Rtn As Integer
  Dim i As Integer
  Dim wFNo As Integer
  '実行確認メッセージ
  Rtn = MsgBox("CSV出力を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Output As #wFNo
  i = 1
  'ループ（繰り返し）の開始
  Do
     i = i + 1
     '該当行の１列目が空白（空値)の場合
     If Cells(i, 1) = "" Then
        'ループを抜ける
        Exit Do
     End If
     'CSV形式にて、1行出力する。
     Write #wFNo, Cells(i, 1), Cells(i, 2), Cells(i, 3)
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox "CSV出力が終了しました。", vbInformation + vbOKOnly
End Sub

モモの紹介

今日は、気分転換して、家族の一員であるモモの紹介です。


知人から貰ったのですが、6歳のチワワでメスです。




室内犬なので、ずーっと、家の中にいますが、毎日、食べる事しか考えていないようです。


我が家の食事の時は、いつも、食卓の下でウロウロしていて、時々、食べ物が落ちてくるので、それを狙っています。


基本的には、何でも食べますが、特に、パンの時は、足元に泣きついてきます。

それと、アイスクリームなんかは、食べ終わったカップや皿をペロペロ舐めたりします。


飼っていて、一番困るのは、床におしっこをする事です。

最近は、洗面所にする事が多いですが、一向に直りません。


ほとんど、散歩には連れて行きませんが、時々、自分で運動不足を解消するためか、すばやい動きをして、前足で掘るまねをします。


また、時々ですが、寝ている時に、かわいらしいイビキをします。


普段はおとなしいですが、知らない人が来ると、物凄い勢いで吼えます。


おしっこ以外は、悪さはしないので、ほんとうに、飼い易いペットです。


それでは！

メニューバーの作り方

今回は、メニューバーにボタンを追加して、そこからプログラムを実行してみます。

VBAエディターの左側のプロジェクトウィンドウの中のThis WorkBookの部分をクリックすると、

このEXCELブックをOpenした時や、終了する時のサブルーチンを書く事ができます。



実際には、下記コーディングをすると、メニューバーへボタンを追加されるので、そのボタンを押すと、プログラムが実行されます。

Option Explicit

'ブック（EXCELファイルを開く時に実行されるサブルーチン）
Private Sub Workbook_Open()
  'エラーがあっても無視して処理を続行するモード
  On Error Resume Next
  '変数の定義
  Dim wCtrl As Variant, wCtrl1 As Variant, wCtrl2 As Variant, wCtrl3 As Variant, wName As String
  'マクロ実行時に、シート表示が更新されないようにするモードにセット
  Application.ScreenUpdating = False   'False→偽、True→真
  'メニューバーの定義
  Application.CommandBars("Worksheet Menu Bar").Controls("マクロサンプル").Delete                  '一旦、該当メニューバーを削除
  Set wCtrl1 = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)   'メニューバーの追加
  With wCtrl1
       .Caption = "マクロサンプル"   '該当メニューバーに名前をセット
  End With
  'メニューバーの中のコマンドバーを定義
  Set wCtrl = wCtrl1.Controls.Add(Type:=msoControlButton)
  With wCtrl
       .Caption = "計算"             '該当コマンドーバーに名前をセット
       .Style = msoButtonCaption     '該当コマンドーバーのスタイルをセット
       .OnAction = "計算"            '該当コマンドーバーの実行サブルーチン名をセット
       .Visible = True               '該当コマンドーバーの表示
  End With
  'メニューバーの中のコマンドバーを定義
  Set wCtrl = wCtrl1.Controls.Add(Type:=msoControlButton)
  With wCtrl
       .Caption = "罫線"
       .Style = msoButtonCaption
       .OnAction = "罫線"
       .Visible = True
  End With
  'メニューバーの中のコマンドバーを定義
  Set wCtrl = wCtrl1.Controls.Add(Type:=msoControlButton)
  With wCtrl
       .Caption = "色づけ"
       .Style = msoButtonCaption
       .OnAction = "色づけ"
       .Visible = True
  End With
  'マクロ実行時に、シート表示が更新されるようにするモードにセット
  Application.ScreenUpdating = True
End Sub

'ブック（EXCELファイルを閉じる時に実行されるサブルーチン）
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  On Error Resume Next
  If Cancel = True Then
     Exit Sub
  End If
  'メニューバーの削除
  Application.CommandBars("Worksheet Menu Bar").Controls("マクロサンプル").Delete
End Sub

メニューバーの右側に、マクロサンプルという文字ボタンが増えていますね！


この技は、知らない人が多いですが、結構、便利です。

これを応用すると、マクロ専用のEXCELファイルを作成しておき、それを実行すると、他のEXCELを開いてもメニューバーはそのままなので、いろいろと便利です！




それでは！

罫線や色を付ける

今回は、罫線や色を付ける機能を追加します。

下記サンプルを見ればわかりますが、罫線サブルーチンと色づけサブルーチンを追加して、前回作成した計算サブルーチンで、その２つのサブルーチンを呼ぶようにしただけです。

Option Explicit

Public Sub 計算()
  Dim i As Integer, wJCL数合計 As Integer, wPGM数合計 As Integer
  i = 1
  'ループ（繰り返し）の開始
  Do
     i = i + 1
     '該当行の１列目が空白（空値)の場合
     If Cells(i, 1) = "" Or Cells(i, 1) = "合計" Then
        'ループを抜ける
        Exit Do
     End If
     wJCL数合計 = wJCL数合計 + Cells(i, 2)
     wPGM数合計 = wPGM数合計 + Cells(i, 3)
  'ループの終了
  Loop
  '最終行+１行目の１列目に「合計」という文字をセット
  Cells(i, 1) = "合計"
  '最終行+１行目の２列目にJCL数合計をセット
  Cells(i, 2) = wJCL数合計
  '最終行+１行目の３列目にPGM数合計をセット
  Cells(i, 3) = wPGM数合計
  Call 罫線
  Call 色づけ
End Sub

Public Sub 罫線()
   Dim i As Integer
    'A1セル～C8セルを選択
    'Range("A1:C8").Select
    i = 1
    Do
       i = i + 1
       If Cells(i, 1) = "" Then
          Exit Do
       End If
    Loop
    Range(Cells(1, 1), Cells(i - 1, 3)).Select
    '選択しているセルに対して、罫線なしにする
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    '選択しているセルに対して、左罫線をセットする
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous     'ラインスタイル
        .Weight = xlThin              '太さ
        .ColorIndex = xlAutomatic     '色
    End With
    '選択しているセルに対して、上罫線をセットする
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、下罫線をセットする
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、右罫線をセットする
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、水平罫線をセットする
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '選択しているセルに対して、垂直罫線をセットする
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '１行目１列目を選択
    Cells(1, 1).Select    '→Range("A1").Selectと書いても良いが、処理系では、Cellsを使用した方が便利
End Sub

Public Sub 色づけ()
    '全セルを選択
    Cells.Select
    '選択しているセルの背景色をなしにする
    Selection.Interior.ColorIndex = xlNone
    'A9セル～C9セルを選択
    Range("A9:C9").Select
    '選択しているセルの装飾をセット
    With Selection.Interior
        .ColorIndex = 4        '背景色を緑色にセット
        .Pattern = xlSolid     '塗り潰し（網掛けなし）
    End With
    'Range("A9:C9").Interior.ColorIndex = 4
    'Cells(9,1).Interior.ColorIndex = 4
    'Cells(9,2).Interior.ColorIndex = 4
    'Cells(9,3).Interior.ColorIndex = 4
    'A1セルを選択
    Range("A1").Select
End Sub

'色づけと同じ動きとなる
Public Sub 色づけ1()
    '全セルを選択
    Cells.Select
    '選択しているセルの背景色をなしにする
    Selection.Interior.ColorIndex = xlNone
    'A9セル～C9セルを選択
    Range("A9:C9").Interior.ColorIndex = 4
    'A1セルを選択
    Range("A1").Select
End Sub

'色づけと同じ動きとなる
Public Sub 色づけ2()
    '全セルを選択
    Cells.Select
    '選択しているセルの背景色をなしにする
    Selection.Interior.ColorIndex = xlNone
    'A9セル～C9セルを選択
    Cells(9, 1).Interior.ColorIndex = 4
    Cells(9, 2).Interior.ColorIndex = 4
    Cells(9, 3).Interior.ColorIndex = 4
    'A1セルを選択
    Range("A1").Select
End　Sub


実行ボタンを押すと、下図のようになったと思います。



大分、プログラムらしくなりましたね！

それでは！

ボタンの作り方

今回は、EXCELシートに、ボタンを追加して、それを押すと、計算するようにしてみます。

1)コントロールツールボックスの表示

画面上部のメニューバーの余白で右クリックして、コントロールツールボックスを選択します。



そうすると、コントロールツールボックスが表示されます。



2)コマンドボタンの追加

コントロールツールボックスの中から、四角いボタンをクリックしてすると、カーソルをシート上に移動すると、十字キーになるので、四角を描くように、ドラッグします。

そうすると、CommandButton1という、ボタンが作成されます。

そのボタンの上で、右クリック→プロパティを選択すると、プロパティウィンドウが表示されるので、Captionプロパティに、ボタン名を入力します。



3)実行ボタンのプログラミング

実行ボタンをダブルクリックすると、VBAエディターに切り替わりますので、下図のように、コーディングします。前回作成した計算サブルーチンを呼んでいるだけですね！



4)デザインモードの終了

デザインモードウィンドウの中のデザインモードの終了ボタンを押し、コントロールツールボックスやプロパティウィンドウを閉じます。

5)ボタンの実行



前回と同じく、合計が計算されましたね！

今回は、ここまで！

それでは！

超入門

さあ、早速、EXCELマクロ超入門です。

1)セキュリティレベルの設定

まずは、EXCELを立ち上げて、画面上部のメニューバーから、ツール→マクロ→セキュリティと辿り、セキュリティレベルを「低」にして下さい。「推奨しません」となっていますが、低にしないと、いちいち、マクロ実行時に確認メッセージが表示されます。それでもいいという方は、セキュリティレベルを中にして下さい。これは、ウィルスを仕込んだマクロがあり得るので、無防備に実行すると危険なので、その対策です。

2)VBAエディター画面

次に、ツール→マクロ→Visual Basic Editorとすると、VBAエディター画面に切り替わりますが、Alt+F11キーを押すと、EXCELシートとVBAエディター画面に、交互に切り替わります。


3)シートでのデータ入力

Alt+F11でシートに切り替えて、下図のように、データを入力して下さい。

4)マクロの作成（標準モジュールの挿入）

Alt+F11でVBAエディター画面に切り替えて、メニューバーから、挿入→標準モジュールとして下さい。標準モジュールというのは、どこからでも呼べる共通の場所と思えば良いです。

5)マクロの作成（プログラミング）

いよいよ、プログラミング開始です。標準モジュールに、下記ソースを入力して下さい。

尚、掲載しているソースは整形の為、空白は全て全角としています。

Option Explicit

Public Sub 計算()
 Dim i As Integer, wJCL数合計 As Integer, wPGM数合計 As Integer
 i = 1 'ループ（繰り返し）の開始
 Do i = i + 1
   '該当行の１列目が空白（空値)の場合
   If Cells(i, 1) = "" Then
     'ループを抜ける
     Exit Do
   End If
   wJCL数合計 = wJCL数合計 + Cells(i, 2)
   wPGM数合計 = wPGM数合計 + Cells(i, 3)
 'ループの終了
 Loop
 '最終行+１行目の１列目に「合計」という文字をセット
 Cells(i, 1) = "合計"
 '最終行+１行目の２列目にJCL数合計をセット
 Cells(i, 2) = wJCL数合計
 '最終行+１行目の３列目にPGM数合計をセット
 Cells(i, 3) = wPGM数合計
End Sub

【説明】
Option Explicit：変数の宣言を強制するオプションで、これを指定しておかないと、変数の宣言をしなくても良くなりますが、意図しない不具合が発生する場合があるので、必ず、宣言しましょう！

Public：どこからでも呼ぶ事ができる宣言です。

Sub：サブルーチンの意味で、プログラムの最小単位です。Subの後に、名前を宣言します。

Dim：変数の宣言で、後ろに名前と変数の型を指定します。

As：後ろに変数の型を指定します。

Integer：整数を表す変数の型です。

i = 1：iという整数に1をセットします。

i = i + 1：iに１を加算します。

Do ～ Loop：ループ宣言で、この間に書いたコードが繰り返されます。

If：IF文の事で、条件により処理を振り分けます。

Cells(i,1)：現在のシートのi行目、1列目のセルの事です。

If Cells(i, 1) = "" Then：i行目、1列目のセルの値が何もない時という意味です。

Exit Do：Do ～ Loopを抜けます。Loop文の直後に、飛びます。

wJCL数合計 = wJCL数合計 + Cells(i, 2)：wJCL数合計という変数に、i行目、2列目の内容を加算します。

Cells(i, 1) = "合計"：i行目、1列目に、「合計」という文字をセットします。

End Sub：サブルーチンの終了宣言です。

という事で、このプログラム（サブルーチン）は、開いているシートの合計を計算しています。

5)マクロの実行

Alt+F11でシートに切り替えて、メニューバーから、ツール→マクロ→マクロとして、マクロ一覧の中から、計算サブルーチンを選択してから実行ボタンを押して下さい。Alt+F8でも、同じ事ができます。

ほら、合計が表示されましたよね！

後は、終了時に、このEXCELファイルを「マクロサンプル.xls」などとして、保存してください。

今回は、ここまでです。

それでは！

自宅待機

私は、ソフトウエア会社に入社して約30年間、オフコンやホスト、PCのシステム開発に携わってきましが、とうとう、今月から自宅待機となってしまいました。

今年に入ってから、ソフトウエア業界は、極端に仕事が減り始めて、特に、若い人や、私みたいに50代以上の人は、特に厳しい状況だったので、ある程度は、予想はしていました。

自宅待機となってから、数日が経過したのですが、この年齢では、アルバイトの口はなく、家でブラブラしていたのですが、何かやらなきゃと思って、自分が一番得意とするEXCELマクロについてのブログを書こうと決心しました。

今までにいろいろな会社のシステム開発をやってきて、開発言語や開発環境も千差万別でしたが、どのプロジェクトでも、結構、手作業が多かったのですが、そういう時は、EXCELマクロ（VBA）で沢山のツールを作って、手作業（業界用語では力仕事と言いますが！）を自動化してきました。

ですから、ことさら、EXCELマクロには、愛着があるので、このブログを立ち上げる気持ちになりました。

EXCELマクロ（VBA）って何？という人もいるでしょうから、簡単に解説しますね！


EXCELは、表計算ソフトの一種ですが、実は、プログラミングもできるのです。EXCEL自身でも、各セルに式を埋め込んで、プログラミングもどきはできるのですが、EXCELには、全く別の顔である、VBA（Visual Basic For Application）という機能が、EXCELマクロになります。


ただ、全く独立した存在という訳ではなく、EXCELが扱うシートやセル、図形などの部品をVBAによって、コントロールする訳です。一番簡単に言うと、EXCELの機能にマクロ記録というのが、あるのですが、これは、EXCELでの手作業を自動的に記録して、その結果をVBAという言語に変換してくれるのです。


先ほど、システム開発には、手作業が多いと言いましたが、まさに、VBAを利用する事により、作業を自動化してくれるのです。ただ、マクロ記録で保存されたVBAのソースは、そのままでは、使い辛い面があるので、扱いやすいように加工してやる必要があります。


慣れてくると、１からコーディングできるようになりますが、それでも、機能が沢山あるので、初めて使う機能の場合は、マクロ記録でソースを生成してから、それを利用するようにします。


そうすれば、ちょっとしたコツを覚えさえすれば、誰でも、ＥＸＣＥＬマクロの達人になれると思います。


次回からは、図を交えて、ＥＸＣＥＬマクロを中心に、PC事情や身の回りの事なども書いて行きたいと思います。

それでは、よろしくお願いします。