ExcelVBA 汎用プログラム サンプル集

IT関連
2019.08.18

エクセルVBAの素晴らしさを伝えたいと思って動画を作っています。

正直私は人に教えられるほどスキルは高くありませんが、素晴らしさを伝えるくらいは出来ると思っております。

下記がその動画の１回目です。現在７回まであります。

 

主旨は入門編の前の導入編です。やる気になれなければ書店で本を手に取ることもありません。

皆さんをやる気にさせることが動画の目的です。

 

なるべく、ご視聴いただいた皆さんが職場や自分の業務を想像できる内容を心がけて作っています。

そこで、私が実際に職場で汎用的に使っているサンプルプログラムを紹介することにしました。

無駄があると思いますが、一応は使えているのでご参考になさってください。

不備がございましたらご指摘いただけると幸いです。

 

よろしければブログも見て頂けると嬉しいです。

 

千で割る

売上とか利益とか合計金額とか単位の円を千円に直したいときに使用します。

使い方

  1. 適用させたいセルを選ぶ（複数セル可能）
  2. 下記マクロを実行する
  3. 選んだセルにあるすべての値が1000で割られ、実質単位千円になります。
Sub 千で割る()
    
    '＜機能説明＞アクティブセルを１０００で除算し単位千円にします。

    'エラーを無視する
    On Error Resume Next
    
    '変数定義
    Dim c As Range          '選択セル
    
    '選択された範囲を対象とし検索
    For Each c In Selection
    
        'アクティブセルが数字の場合
        If VarType(c) = vbDouble Then
            
            '1000で割算し、０桁目で四捨五入する
            c.Value = Round(c.Value / 1000, 0)
        
        End If
            
    Next

End Sub

 

ゼロで桁埋め

数字の００１が単なる１になってしまうときに、０を先頭に補完して００１で表示するプログラムです。

通常数字の先頭には０は入りません。０を入れたとたん文字として認識します。特段問題はありませんがご注意ください。

使い方

  1. 適用させたいセルを選ぶ（複数セル可能）
  2. マクロを実行する
  3. ポップアップで桁数を聞かれますので入力してください。001の3桁なら3、0001の4桁なら4。
  4. 選んだセルにあるすべての値の先頭に０が入ります。
Sub ゼロで桁埋め()

    '＜機能説明＞
    '００１などが１と表示されるのを、文字列として０で桁埋めします。
    
    '変数定義
    Dim c As Range        'ForEach用オブジェクト変数
    Dim Buf As String     'インプットボックスからの戻り値
    Dim Keta As String    '桁数
    
    '０で埋める桁数を入力させる
    Buf = InputBox("桁数を2～5で入れて下さい。", "０で桁埋めします。")
    
    '全角数字が来てもいいように半角に直す
    Buf = StrConv(Buf, vbNarrow)
    
　　 '入力された値を判定する
    Select Case Buf
    
        Case 2
        Keta = "'00"
        Case 3
        Keta = "'000"
        Case 4
        Keta = "'0000"
        Case 5
        Keta = "'00000"
        
        Case Else
        
        'キャンセルか該当しない場合は終了
        MsgBox "正しい桁数を入れて下さい。終了します。", vbInformation
        Exit Sub
    
    End Select
    
    'アクティブセルの範囲を対象とし処理
    For Each c In Selection
    
        '指定桁数を事前設定
        c.NumberFormatLocal = Keta
        '指定桁数込みで代入
        c.Value = Format(c.Value, Keta)
        
    Next

End Sub

 

 

アクティブセルの文字でブックを保存する

名前をつけて保存するのって面倒ですよね。「名前を付けて保存」から「ファイル名」を打ち込んで「保存ボタン」を押す作業。

ファイル名をそのまま「Book1」にすると後でなんだかわからなくなります。

そもそも保存するということは、タイトルなりテーマなり何らかの文字をエクセル上に打っているはずです。

それなら、その文字を使って保存しようというのが趣旨です。

使い方

  1. 保存したい名前のセルをクリックする（複数セル選択不可）
  2. マクロを実行する
  3. 以上。選択したセルの文字でExcelブックがデスクトップに保存されます。
Sub ブック保存()
    
    '＜機能説明＞アクティブセルの値をファイル名としてデスクトップに保存します。
    
    '変数定義
    Dim StartOK As String       '実行確認の返事
    Dim FileName As String      'ファイル名
    Dim UserName As String      'ユーザ名
    
    'アクティブセルを複数選択している場合はエラー表示
    If Selection.Count <> 1 Then
      MsgBox "セルは１つだけ選んでください。", vbCritical, "お知らせ"
      Exit Sub
    End If

    'セルの値がない場合はエラー
    If ActiveCell.Value = "" Then
      MsgBox "文字が入ったセルをクリックしてください", vbCritical
      Exit Sub
    End If
      
    '実行前確認
    StartOK = MsgBox("アクティブセルの値をファイル名として" & vbCrLf & "Excelを保存します。" _
    & vbCrLf & "よろしいですか？", vbYesNo, "実行前確認")
    
    'Ｎｏを選んだらここでプログラム終了
    If StartOK = vbNo Then Exit Sub
    
    'アクティブセルの値を変数に
    FileName = ActiveCell.Value
        
    'ログインユーザ名を取得する
    UserName = Environ("username")
    
    'デスクトップに保存する
    ActiveWorkbook.SaveAs FileName:="C:\users\" & UserName & "\desktop\" & FileName, _
    FileFormat:=xlOpenXMLWorkbookMacroEnabled   'マクロ有効ブック
    
End Sub

 

アクティブセルの文字でＰＤＦを生成する

エクセルのシートからＰＤＦをボタン一つで生成する方法です。

エクセルをＰＤＦにすること自体は簡単です。名前をつけて保存からＰＤＦを選ぶだけです。

しかしこれも上記のエクセルの保存と同じく、普通にやると面倒なのでマクロ化しようという話です。

使い方

  1. 保存したい名前のセルをクリックする（複数セル選択不可）
  2. マクロを実行する
  3. 以上。選択したセルの文字でPDFがデスクトップに保存されます。
Sub PDF生成()
   
    '＜機能説明＞アクティブセルの値をファイル名としてデスクトップにPDFを生成します。
    
    '変数定義
    Dim StartOK As String       '実行確認の返事
    Dim FileName As String      'ファイル名
    Dim UserName As String      'ユーザ名
    
    'アクティブセルを複数選択している場合はエラー表示
    If Selection.Count <> 1 Then
      MsgBox "セルは１つだけ選んでください。", vbCritical, "お知らせ"
      Exit Sub
    End If

    'セルの値がない場合はエラー
    If ActiveCell.Value = "" Then
      MsgBox "文字が入ったセルをクリックしてください", vbCritical
      Exit Sub
    End If
      
    '実行前確認
    StartOK = MsgBox("アクティブセルの値をファイル名として" & vbCrLf & "PDFを生成します。" _
    & vbCrLf & "よろしいですか？", vbYesNo, "実行前確認")
    
    'Ｎｏを選んだらここでプログラム終了
    If StartOK = vbNo Then Exit Sub
    
    'アクティブセルの値を変数に
    FileName = ActiveCell.Value
        
    'ログインユーザ名を取得する
    UserName = Environ("username")
        
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
    "C:\Users\" & UserName & "\Desktop\" & FileName & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub

 

 

先頭行を固定し印刷タイトルにする

エクセルは表計算ソフトなので当然のことながら表を作ることが多いです。

行数が多くなると、スクロールしたときや複数枚印刷するときに、表のタイトルが固定されている方が良いことあると思います。

それを１ボタンで実現するマクロです。

使い方

  1. マクロを実行する
  2. 以上。表示も印刷も１行目が固定されます。
Sub 先頭行固定()

    '＜機能説明＞画面と印刷ページの先頭行を固定します
    
    'A2セルを起点とする
    Range("A2").Select

    '先頭行を固定する
    With ActiveWindow
      .FreezePanes = False
      .ScrollRow = 1
      .ScrollColumn = 1
      .FreezePanes = True
    End With
    
    '１行目を印刷タイトルにする
    ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
    
End Sub

 

続きは動画で紹介するたびに追加いたします。

よろしくお願いいたします。

スポンサーリンク

コメント

タイトルとURLをコピーしました