【VBA】オリジナルプログレスバーを実装する

0

    <機能>

    (1)オリジナル(独自)のプログレスバーを作成します

     ※ActiveXのプログレスバーは使用しません

    (2)フレームの中に背景が緑のラベルを配置してWidth変更により進捗表示します

    (3)透明ラベルにて進捗「999 / 999 %」を表示します

    (4)キャンセル(中断)押下により処理を中断できます

     

    <動作検証&開発環境>
    Microsoft Office2016

     

    <実行イメージ>

    ユーザフォーム表示直後のイメージ

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    窪んだフレーム中の緑のラベルのWidthを変化させます

    進捗表示ラベルは背景を透明に設定しています

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    キャンセル押下により中断できます

    [X]ボタンや[Alt]+[F4]でも同じ動作をします

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

     

    <使い方>
    (1)[挿入]メニューからユーザフォームを挿入します
    ※名前はUserForm1(デフォルト名)とします

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    (2)コントロールを配置します

    ・Frame1

     Caption : なし

     Width : 400

     SpecialEffect : fmSpecialEffectSunken(窪みフレーム)

    ・Label1

     BackColor : 緑(なんでもいいです)

     Caption : なし

     Width : 400(フレームの中に配置)

    ・Label2

     BackStyle : mBackStyleTransparent(背景透明)

     TextAlign : fmTextAlignCenter(中央揃え)

    ・CommandButton1

     Caption : スタート

    ・CommandButton2

     Caption : キャンセル

     

    (3)ソースをUserForm1に貼り付けます

     

    '//Windows API
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Const HWND_TOPMOST As Long = -1
    Private Const SWP_NOSIZE As Long = &H1&
    Private Const SWP_NOMOVE As Long = &H2&

     

    '//キャンセルボタン押下判定フラグ
    Public bCancel As Boolean
    '//プログレスバー実行中フラグ
    Public bProgress As Boolean

     

    '/********************************************************
    '/* ユーザフォームを常に前面に表示
    '/********************************************************

    Private Sub UserForm_Activate()
        Call SetWindowPos(GetForegroundWindow, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    End Sub

     

    '/********************************************************
    '/* ユーザフォームの初期化
    '/********************************************************

    Private Sub UserForm_Initialize()
        
        '//ラベルの位置を明示的に指定
        '//フレーム(Frame1)とラベル(Label1)の左上座標&幅を合わせる

        With Me.Label1
            .Left = 0
            .Top = 0
            .Width = 400
            .Visible = False
        End With
        
        '//ラベル2(プログレスバーの進捗表示用)初期表示
        Me.Label2.Caption = "スタートボタンを押してください"
        '//キャンセルボタン押下フラグ
        bCancel = False
        '//プログレスバー実行中フラグ
        bProgress = False
    End Sub

     

    '/********************************************************
    '/* [スタート]押下によりプログレスバー開始
    '/********************************************************

    Private Sub CommandButton1_Click()
        Dim iBar As Integer
        Dim strMsg As String
        
        '//初期値セット
        iBar = 0
        bCancel = False
        strMsg = "おわりました"
        '//プログレスバー(ラベル)は最初は幅0
        Me.Label1.Width = 0
        Me.Label1.Visible = True
        '//ラベル2(プログレスバーの進捗表示用)は0を初期表示
        Me.Label2.Caption = "  0 / 100 %"
        
        '//プログレスバー開始
        bProgress = True
        Do
            '0-100まで
            If iBar = 100 Then Exit Do
            
            '200ミリ秒ごとにカウントアップ
            '大括弧[]で囲むとSleepを使わなくてもミリ秒指定が可能です
            'Application.Wait Now + TimeValue("0:00:01")

            Application.Wait [Now() + "0:00:00.2"]
            iBar = iBar + 1
            
            'ラベルの幅を400としているのでカウンター×4とする
            Me.Label1.Width = (iBar * 4)
            '進捗表示(分子はスペース埋めで3桁固定とする)
            Me.Label2.Caption = Format(CStr(iBar), "@@@") & " / 100 %"
            '再描画
            Me.Repaint
            
            'キャンセルボタン押下等のイベント処理
            DoEvents
            If bCancel Then
                If MsgBox("キャンセルしてもよろしいですか?", vbQuestion + vbYesNo) = vbYes Then
                    'メッセージで[はい]が押下されたらキャンセルする
                    strMsg = "キャンセルされました"
                    Exit Do
                Else
                    'メッセージで[いいえ]が押下されたらキャンセル処理をスキップ
                    bCancel = False
                End If
            End If
        Loop
        
        '//プログレスバー終了
        bProgress = False
        '//終了メッセージ表示
        MsgBox strMsg, vbInformation
        
    End Sub

     

    '/********************************************************
    '/* [キャンセル]押下イベントハンドラ
    '/********************************************************

    Private Sub CommandButton2_Click()
        '//キャンセル処理へ進む
        bCancel = True
    End Sub

     

    '/********************************************************
    '/* 「x」ボタンでフォームを閉じないようにする
    '/********************************************************

    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        '//プログレスバー実行中に「x」またはAlt+F4でフォームを閉じようとしたとき
        If bProgress Then
            If CloseMode = vbFormControlMenu Then
                '//キャンセル処理へ進む
                bCancel = True
                '//閉じるボタン「x」では閉じない
                Cancel = True
            End If
        End If
    End Sub
     

     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     


    【VBA】シートをPDFで出力する(ExportAsFixedFormat使用)

    0

      <機能>

      (1)ExportAsFixedFormatを使用してシートをPDFで出力します

       ※ExportAsFixedFormatの対象はOffice 2013以降です

       ※マクロ実行時に必ずブックをマクロ有効形式(.xlsm)で保存してください

      (2)サンプルの出力対象シートを自動で生成します

       ※コピペのみで動作確認できます

      (3)印刷範囲、ヘッダー、フッターも自動で設定します

       

      <動作検証&開発環境>
      Microsoft Office2016

       

      <実行イメージ>

      サンプルの出力対象シートを自動で生成

      VBA,PDF,ExportAsFixedFormat,印刷範囲,PDF変換,PDF出力,

      ExportAsFixedFormatを使用してシートをPDFで出力

      VBA,PDF,ExportAsFixedFormat,印刷範囲,PDF変換,PDF出力,

       

      <使い方>

      適当なところにソースを貼り付けてください

      実行前にブックをマクロ有効形式(.xlsm)で保存してください

      (400、1004などの実行エラーとなります)

      PDF出力メイン() を実行すると処理を開始します

       

      '********************************************
      'シートをPDFで出力するサンプルプログラム
      '(1)出力対象のサンプル明細書を自動生成
      '(2)印刷範囲、ヘッダー、フッターを設定
      '(3)PDFファイルを出力
      '※ExportAsFixedFormatの対象:Office 2013 and later
      '********************************************

      Public Sub PDF出力メイン()
          '//描画を停止
          Application.ScreenUpdating = False
          
          '//(1)出力対象のサンプル明細書を自動生成
          サンプル明細書作成
          
          '//(2)印刷範囲、ヘッダー、フッターを設定
          '//PageSetupメンバーの詳細については Office DevCenter を参照

          With ActiveSheet.PageSetup
              '印刷の向き(横:xlLandscape 縦:xlPortrait)
              .Orientation = xlLandscape
              
              '横1ページ×縦1ページ
              .Zoom = False
              .FitToPagesWide = 1
              .FitToPagesTall = 1
              
              'ヘッダーを設定
              '詳細は ヘッダーとフッターに指定できる書式コード 参照
              '日付と現在時刻

              .RightHeader = "印刷日時:&D(&T)"
              
              'フッターを設定
              'ページ番号

              .CenterFooter = "&P/&N"
              'ブック名とシート名
              .RightFooter = "&F(&A)"
              
              '余白設定
              '上3、左1.5、右1.5、下2、ヘッダー2、フッター1

              .TopMargin = Application.CentimetersToPoints(3)
              .LeftMargin = Application.CentimetersToPoints(1.5)
              .RightMargin = Application.CentimetersToPoints(1.5)
              .BottomMargin = Application.CentimetersToPoints(2)
              .HeaderMargin = Application.CentimetersToPoints(2)
              .FooterMargin = Application.CentimetersToPoints(1)
              
              '水平方向ページ中央
              .CenterHorizontally = True
          End With
          
          '//改ページプレビュー表示
          ActiveWindow.View = xlPageBreakPreview
          '//ズーム100%で表示
          ActiveWindow.Zoom = 100
          
          '//(3)PDFファイルを出力
          '//ファイル名にF4セルの氏名をセット(スペースはトリムする)

          Dim strPdf As String
          strPdf = ThisWorkbook.Path & "¥Meisai_" & Replace(Replace(Range("F4").Text, " ", ""), " ", "") & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".pdf"
          
          '//PDFに変換する
          '//ExportAsFixedFormatメソッドの詳細については Office DevCenter を参照

          ThisWorkbook.Sheets(ThisWorkbook.ActiveSheet.Index).ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPdf, Quality:=xlQualityStandard
          
          '//描画を再開
          Application.ScreenUpdating = True
      End Sub


      '********************************************
      'PDF出力対象のサンプル明細書を生成
      '(1)サンプルデータをセット
      '(2)帳票の体裁を自動で設定
      '********************************************

      Public Sub サンプル明細書作成()
          Dim ar As Variant
          ar = Array( _
          "経費明細書,,,,,,,,", _
          "サンプル株式会社 総務部,,,,,,,,", _
          "〒000-0000 東京都新宿区西新宿1丁目,,,,,,,,", _
          "電話,(03)9999-9999,,氏名,山田 太郎,,,,", _
          "FAX,(03)9999-9998,,部署,営業部,,,,", _
          "電子メール,info@abcdef.com,,職位,管理責任者,,,,", _
          "Web,www.abcdef.com,,上司,鈴木 イチロウ,,,,", _
          ",,,,,,,,", _
          "日付,勘定科目,内容,宿泊費,交通費,食費,通信費,雑費,合計", _
          "43070,営業経費,旅費,44500,22500,2000,,500,69500", _
          "43085,営業経費,営業会議,,13500,,,,13500", _
          "43092,営業経費,営業会議,,13500,,1600,,15100", _
          "合計,,,44500,49500,2000,1600,500,98100")

          '//シートをクリア
          ThisWorkbook.Activate
          Cells.Select
          Selection.Clear
          Selection.ColumnWidth = 20
          Selection.RowHeight = 25
          Selection.Font.Name = "メイリオ"
          Selection.Font.Size = 11
          Selection.Borders.LineStyle = False
          
          '//セルの折り返しを解除
          Selection.WrapText = False
          '//列幅調整
          Columns("A").ColumnWidth = 3
          '//帳票タイトル調整
          With Rows("1")
              .RowHeight = 40
              .VerticalAlignment = xlTop
              .Font.Size = 25
              .Font.Bold = True
          End With
          
         '//データをシートに展開
          Dim i As Integer, j As Integer
          Dim wkbuf As Variant
          
          For i = 0 To UBound(ar)
              wkbuf = Split(ar(i), ",")
              '不正なデータであれば次レコードへ
              If UBound(wkbuf) <> 8 Then GoTo nextrec
              'データを表示
              For j = 0 To UBound(wkbuf)
                  '表示はB列からのため(j + 1)とする
                  Cells(i + 1, (j + 1) + 1) = wkbuf(j)
              Next j
          
      nextrec:
          Next i
          
          '//セルにインデントを設定
          With Range("C4:C7,F4:F7")
              .IndentLevel = 1
              .Borders(xlEdgeLeft).LineStyle = xlContinuous
              .Borders(xlEdgeLeft).Weight = xlThin
          End With
          '//表に罫線を引く
          With Range("B9:J13")
              .Borders.LineStyle = xlContinuous
              .Borders.Weight = xlThin
          End With

          '//項目行を中央揃えにする
          With Range("B9:J9")
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter
              .Interior.Color = RGB(128, 128, 128)
              .Font.Color = RGB(255, 255, 255)
          End With
          
          '//合計行の設定
          With Range("B13:J13")
              .Interior.Color = RGB(217, 217, 217)
              .Font.Bold = True
          End With
          With Range("B13")
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter
          End With
          '//金額書式設定(円マーク付き、カンマ区切り)
          Range("E10:J13").NumberFormatLocal = "¥#,##0; ¥-#,##0"
          '//日付書式設定(YYYY年MM月DD日形式)
          With Range("B10:B12")
              .NumberFormatLocal = "yyyy""年""mm""月""dd""日"""
              .HorizontalAlignment = xlCenter
          End With
          Range("A1").Select
      End Sub

       

      よろしければポチッと押してください

      プログラマー ブログランキングへ


      【VBA】独自のメニューバー/右クリックメニューを設定する

      0

        <機能>

        (1)独自のメニューバー(コマンドバー)を設定します

         [アドイン](メニュー)

          [備忘録サンプル](オリジナル)  

           緑でフォームを表示

           ピンクでフォームを表示

        (2)コマンドバーはワークブックオープンで生成、クローズで破棄されます

        (3)独自の右クリックメニュー(セル右クリックメニュー)を設定します

        (4)下記メニュー機能を実装します

         緑でフォームを表示(MainShow1プロシージャコール)

         ピンクでフォームを表示(MainShow2プロシージャコール)

        (5)フォームの表示位置を保持します

         

        <動作検証&開発環境>
        Microsoft Office2016

         

        <実行イメージ>

        アドインメニューに独自メニューを設定します

        CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,コマンドバー削除

        セルを右クリックすると独自メニューが表示されます

        CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,,コマンドバー削除

        [緑でフォームを表示]をクリックするとMainShow1がコールされます

        ユーザフォーム,背景色,CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

        [ピンクでフォームを表示]をクリックするとMainShow2がコールされます

        ユーザフォーム,背景色,CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

         

        <使い方>

        (1)[挿入]メニューからユーザフォームを挿入します

        ※名前はUserForm1(デフォルト名)とします

        CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

        (2)[挿入]メニューから標準モジュールを挿入します

        ※名前はModule1(デフォルト名)とします

        CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

        (3)ユーザフォーム(UserForm1)にボタンコントロールを貼り付けます

        ※名前はbtnClose、キャプションを「閉じる」とします

        CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

         

        (4)ソースを貼り付けます

         

        ’ThisWorkbook(OpenとBeforeCloseイベント処理追加)

        '/********************************************************
        '/* ワークブックオープンでメニューバーを作成
        '/********************************************************

        Private Sub Workbook_Open()
            Dim wkstr As String
            
            'メニューバーの作成
            Call Module1.CreateMenu
            'ポップアップメニューの作成
            Call Module1.CreatePopUp
            
            'フォームの初期表示位置はエクセルアプリケーションの左上
            Module1.XPOS = Application.Left
            Module1.YPOS = Application.Top
            
            '先頭シートのA1選択
            ThisWorkbook.Sheets(1).Select
            Range("A1").Select
        End Sub

         

        '/********************************************************
        '/* ワークブッククローズでメニューバーを削除
        '/********************************************************

        Private Sub Workbook_BeforeClose(Cancel As Boolean)
            Dim objCB As CommandBar
            
            Set objCB = Application.CommandBars("Worksheet Menu Bar")

            'メニューバーが作成済みであれば削除する
            On Error Resume Next
            objCB.Controls(Module1.CAP_MAIN).Delete
            
            objCB = Nothing
        End Sub

         

        ’Module1(定数定義と独自メニュー生成処理を追加)

        '//フォームの表示位置を保持
        Public XPOS As Integer
        Public YPOS As Integer

        Public Const CAP_MAIN = "備忘録サンプル"
        Public Const MENU1 = "緑でフォームを表示"
        Public Const MENU2 = "ピンクでフォームを表示"


        '/********************************************************
        '/* メニューバー(アドインメニュー)の作成
        '/********************************************************

        Public Sub CreateMenu()
            Dim objCB As CommandBar
            Dim CmdCtrl As CommandBarControl
            Dim CmdBtn1 As CommandBarButton, CmdBtn2 As CommandBarButton
            
            Set objCB = Application.CommandBars("Worksheet Menu Bar")

            '作成済みであれば削除
            On Error Resume Next
            objCB.Controls(CAP_MAIN).Delete
            On Error GoTo 0
            
            Set CmdCtrl = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)
            CmdCtrl.Caption = CAP_MAIN
            
            Set CmdBtn1 = CmdCtrl.Controls.Add(Type:=msoControlButton)
            CmdBtn1.Caption = MENU1
            CmdBtn1.OnAction = "MainShow1"
            
            Set CmdBtn2 = CmdCtrl.Controls.Add(Type:=msoControlButton)
            CmdBtn2.Caption = MENU2
            CmdBtn2.OnAction = "MainShow2"
        End Sub

         

        '/********************************************************
        '/* ポップアップメニュー(右クリックメニュー)の作成
        '/********************************************************

        Public Sub CreatePopUp()
            Dim CmdBar As CommandBar
            Dim CmdBtn1 As CommandBarButton, CmdBtn2 As CommandBarButton
            
            Set CmdBar = CommandBars("Cell")
            CmdBar.Reset
            Set CmdBtn1 = CmdBar.Controls.Add(msoControlButton, Temporary:=True)
            CmdBtn1.BeginGroup = True
            CmdBtn1.Caption = MENU1
            CmdBtn1.OnAction = "MainShow1"
               
            Set CmdBtn2 = CmdBar.Controls.Add(msoControlButton, Temporary:=True)
            CmdBtn2.BeginGroup = True
            CmdBtn2.Caption = MENU2
            CmdBtn2.OnAction = "MainShow2"
               
            Set CmdBar = Nothing
            Set CmdBtn1 = Nothing
            Set CmdBtn2 = Nothing
        End Sub

         

        '/********************************************************
        '/* メニュー画面の表示
        '/* MENU1からコールされた場合はMainShow1
        '/* MENU2からコールされた場合はMainShow2
        '/********************************************************

        Public Sub MainShow1()
            'フォームのキャプション変更
            UserForm1.Caption = Module1.MENU1
            'メニュー画面の背景色を設定
            UserForm1.BackColor = RGB(169, 208, 142)
            UserForm1.btnClose.BackColor = RGB(169, 208, 142)
            'メニュー画面表示
            UserForm1.Show vbModal
        End Sub

         

        Public Sub MainShow2()
            'フォームのキャプション変更
            UserForm1.Caption = Module1.MENU2
            'メニュー画面の背景色を設定
            UserForm1.BackColor = RGB(255, 178, 255)
            UserForm1.btnClose.BackColor = RGB(255, 178, 255)
            'メニュー画面表示
            UserForm1.Show vbModal
        End Sub

         

        'UserForm1(表示位置の設定、Clickイベント)

        '/********************************************************
        '/* フォームの表示位置を指定
        '/********************************************************

        Private Sub UserForm_Activate()
            Application.ScreenUpdating = False
            Me.Left = Module1.XPOS
            Me.Top = Module1.YPOS
            Application.ScreenUpdating = True
        End Sub

         

        '/********************************************************
        '/* [閉じる]ボタン押下時の処理
        '/********************************************************

        Private Sub btnClose_Click()
            Unload Me
        End Sub

         

        '/********************************************************
        '/* フォームを閉じるときの処理
        '/********************************************************

        Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
            Module1.XPOS = Me.Left
            Module1.YPOS = Me.Top
            
            '[x]ボタンで閉じれなくする
            If CloseMode = vbFormControlMenu Then
                Cancel = True
            End If
        End Sub
         

        よろしければポチッと押してください

        プログラマー ブログランキングへ


        【VBA】ドキュメントプロパティを設定する

        0

          <機能>

          ブックのドキュメントプロパティ(BuiltinDocumentProperties)を設定します

          (1)新規ブックにドキュメントプロパティをセット

          (2)先頭シートにドキュメントプロパティの内容を出力します

           

          <動作検証&開発環境>

          Microsoft Office2016

           

          <実行イメージ>

          シートにドキュメントプロパティの内容を出力

          VBA,BuiltinDocumentProperties,プロパティ設定,タイトル,件名,タグ,分類項目,コメント,作成者,改定番号,バージョン番号,会社,マネージャー,コンテンツの作成日時,

          VBA,BuiltinDocumentProperties,プロパティ設定,タイトル,件名,タグ,分類項目,コメント,作成者,改定番号,バージョン番号,会社,マネージャー,コンテンツの作成日時,

           

          <使い方>

          適当なところにソースを貼り付けてください

          新規ブックにプロパティを設定する() を実行すると処理を開始します

           

          '********************************************
          'VBAで新規ブックにプロパティを設定する
          '(1)ブックを新規作成
          '(2)プロパティを設定
          '(3)シートにプロパティの内容を出力して保存
          '********************************************

          Sub 新規ブックにプロパティを設定する()
              Dim strName As String
              Dim gyo As Integer

           

              '//ブック名を生成
              strName = ThisWorkbook.Path & "¥SAMPLE_" & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".xlsx"

           

              '//テスト用ブックを新規作成
              '//FileFormatにExcelブック(*.xlsx)形式を指定
              Workbooks.Add

           

              '//ブックを保存する(ファイル形式に.xlsx:xlOpenXMLWorkbookを指定)
              '//XlFileFormat列挙体の設定値についてはOffice DevCenter参照

              ActiveWorkbook.SaveAs Filename:=strName, FileFormat:=xlOpenXMLWorkbook
              ActiveWorkbook.Close

           

              '//ブックにプロパティを設定
              Workbooks.Open strName
              With Workbooks(Mid(strName, InStrRev(strName, "¥") + 1))
                  'タイトル
                  .BuiltinDocumentProperties("Title").Value = "ブックにプロパティをセット"
                  '件名
                  .BuiltinDocumentProperties("Subject").Value = "プロパティの設定と取得のテスト"
                  'タグ
                  .BuiltinDocumentProperties("Keywords").Value = "VBA BuiltinDocumentProperties"
                  '分類項目
                  .BuiltinDocumentProperties("Category").Value = "VBAプログラムサンプル"
                  'コメント
                  .BuiltinDocumentProperties("Comments").Value = "平成28年12月会議にて使用予定" & vbCrLf & "佐藤部長レビュー済み資料(2016.11.05)"
                  '作成者
                  .BuiltinDocumentProperties("Author").Value = "山田 太郎"
                  '改定番号(整数)
                  .BuiltinDocumentProperties("Revision Number").Value = "4"
                  'バージョン番号
                  .BuiltinDocumentProperties("Document version").Value = "1.0.8"
                  '会社
                  .BuiltinDocumentProperties("Company").Value = "株式会社○△□"
                  'マネージャー
                  .BuiltinDocumentProperties("Manager").Value = "田中部長"
                  'コンテンツの作成日時
                  .BuiltinDocumentProperties("Creation Date").Value = "2016/12/20 10:09"

           

                  '//すべてのプロパティを先頭シートに出力する
                  .Sheets(1).Activate

           

                  '//セル幅、フォントを指定
                  Columns("A:B").Select
                  Selection.Clear
                  Selection.ColumnWidth = 30
                  Selection.RowHeight = 50
                  Selection.Font.Name = "メイリオ"
                  Selection.Font.Size = 10
                  '//折り返して全体を表示
                  Selection.WrapText = True
                  '//水平方向左、垂直方向中央揃え
                  Selection.HorizontalAlignment = xlLeft
                  Selection.VerticalAlignment = xlCenter
                  Range("A1").Select

           

                  '//エラー処理ルーチンを有効
                  On Error Resume Next
                  gyo = 1
                  For Each p In .BuiltinDocumentProperties
                      Cells(gyo, 1).Value = p.Name
                      Cells(gyo, 2).Value = p.Value
                      gyo = gyo + 1
                  Next
                  On Error GoTo 0

           

                  '//ブックをクローズ
                  .Close True
              End With
          End Sub
           

          よろしければポチッと押してください

          プログラマー ブログランキングへ

           


          【VBA】表の体裁を整え、印刷範囲/ヘッダー/フッターを設定する

          0

            <機能>

            VBAで表の体裁を整え、即印刷できるようにシートを設定します

            (1)シートを挿入しテストデータ「鮮魚の一人当たり購入数量」をセット
            (2)セル幅、セル内の表示位置、罫線等をセット
            (3)印刷範囲、ヘッダー、フッターをセット

             

            <動作検証&開発環境>
            Microsoft Office 2016

             

            <実行イメージ>

            元のテキストのみ状態

            表,体裁,ColumnWidth,フォントサイズ,フォント,中央揃え

            セル幅、セル内の表示位置、罫線等をセット

            VBA,PageSetup,LineStyle,FitToPagesWide,印刷設定,横向き

            即印刷できるように印刷範囲、ヘッダー、フッターも設定済み

            CenterHeader,CenterFooter,Margin,水平方向,ズーム

             

            <使い方>

            適当なところにソースを貼り付けてください

            表の体裁を自動で設定する() を実行すると処理を開始します

             

            '********************************************

            'VBAで表の体裁を自動で整える

            '(1)シートを挿入しテストデータ「鮮魚の一人当たり購入数量」をセット

            '(2)セル幅、罫線をセット

            '(3)印刷範囲、ヘッダー、フッターをセット

            '********************************************

            Sub 表の体裁を自動で設定する()

                Dim strwk As String

                Dim lgyo As Long, lclm As Long

                

                '新規シートを先頭に挿入

                ThisWorkbook.Activate

                strwk = Now

                ThisWorkbook.Worksheets.Add before:=Worksheets(1)

                Sheets(1).Name = "表の体裁を設定_" & Format(strwk, "yyyymmddhhmmss")

                Sheets(1).Activate

                

                '//(1)アクティブシートにテストデータをセット

                SetTestData

                

                'データの入っている最終行、最終列を取得

                lgyo = Cells(Rows.Count, 1).End(xlUp).Row

                lclm = Cells(5, 1).End(xlToRight).Column

                

                '//(2)セル幅、罫線をセット

                Range(Cells(1, 1), Cells(lgyo, lclm)).Select

                Selection.ColumnWidth = 10

                Selection.RowHeight = 20

                Selection.Font.Name = "メイリオ"

                Selection.Font.Size = 11

                '折り返して全体を表示

                Selection.WrapText = True

                '水平方向、垂直方向中央揃え

                Selection.HorizontalAlignment = xlCenter

                Selection.VerticalAlignment = xlCenter

                

                'A列の2行目と9行目の設定

                With Range("A2", "A9")

                    '「折り返して全体を表示」設定なし

                    .WrapText = False

                    '「縮小して全体を表示」も念のため未設定にしておく

                    .ShrinkToFit = False

                    '水平方向左揃えを設定

                    .HorizontalAlignment = xlLeft

                End With

                

                '表全体に罫線を設定(実線、極細)

                With Range("A4:N7")

                    'Bordersの引数は省略

                    .Borders.LineStyle = xlContinuous

                    .Borders.Weight = xlThin

                End With

                

                '項目行に背景色とセルの下に2本線を設定

                With Range("A4:N4")

                    .Borders(xlEdgeBottom).LineStyle = xlDouble

                    .Interior.Color = RGB(169, 208, 142)

                End With

                

                '//(3)印刷範囲、ヘッダー、フッターをセット

                '//PageSetupメンバーの詳細については Office DevCenter を参照

                With ActiveSheet.PageSetup

                    '印刷時の拡大率(今回は横1ページ×縦未指定 とするため指定なし)

                    .Zoom = False

                    '横1ページ×縦未指定

                    .FitToPagesWide = 1

                    .FitToPagesTall = False

                    '印刷の向き(横:xlLandscape 縦:xlPortrait)

                    .Orientation = xlLandscape

                    

                    'ヘッダーを設定

                    '詳細は ヘッダーとフッターに指定できる書式コード 参照

                    'タイトル(ゴシック・太字・24pt・下線付き)

                    .CenterHeader = "&""MS Pゴシック,太字""&24&U水産物の消費動向"

                    '日付と現在時刻

                    .RightHeader = "印刷日時:&D(&T)"

                    

                    'フッターを設定

                    'ページ番号

                    .CenterFooter = "&P/&N"

                    'ブック名とシート名

                    .RightFooter = "&F(&A)"

                    

                    '余白設定

                    '上3、左1.5、右1.5、下2、ヘッダー2、フッター1

                    .TopMargin = Application.CentimetersToPoints(3)

                    .LeftMargin = Application.CentimetersToPoints(1.5)

                    .RightMargin = Application.CentimetersToPoints(1.5)

                    .BottomMargin = Application.CentimetersToPoints(2)

                    .HeaderMargin = Application.CentimetersToPoints(2)

                    .FooterMargin = Application.CentimetersToPoints(1)

                    

                    '水平方向ページ中央

                    .CenterHorizontally = True

                End With

                

                '改ページプレビュー表示

                ActiveWindow.View = xlPageBreakPreview

                'ズーム85%で表示

                ActiveWindow.Zoom = 85

                

                '設定終了メッセージ

                Range("A1").Select

                MsgBox "設定がおわりました", vbInformation

            End Sub

             

            '********************************************

            'シートに「鮮魚の1人当たり購入数量ぼ品目別割合」表を作成する

            '出典 水産庁「水産物の消費動向

            '********************************************

            Sub SetTestData()

                Dim ar As Variant, wkbuf As Variant

                Dim i As Integer

                

                ar = Array(",,,,,,,,,,,,,", _

                "図2-1-4 鮮魚の1人当たり購入数量の品目別割合,,,,,,,,,,,,,", _

                ",,,,,,,,,,,,,単位:Kg", _

                ",マグロ,アジ,イワシ,カツオ,カレイ,サケ,サバ,サンマ,タイ,ブリ,イカ,タコ,その他", _

                "昭和40年,0.57,1.92,0.38,0.19,0.77,0.44,1.59,0.44,0.39,0.34,1.78,0.36,5.29", _

                "昭和57年,0.83,0.69,0.68,0.37,0.76,0.27,0.52,0.42,0.27,0.58,1.62,0.38,5.06", _

                "平成22年,0.8,0.45,0.26,0.36,0.4,0.95,0.41,0.54,0.23,0.67,0.82,0.27,3.6", _

                ",,,,,,,,,,,,,", _

                "資料:総務省「家計調査」(昭和40年、昭和57年は全世帯(農林漁家世帯を除く)、平成22年は二人以上の世帯(農林漁家世帯を除く))に基づき水産庁で作成,,,,,,,,,,,,,")

                

                For i = 0 To UBound(ar)

                    wkbuf = Split(ar(i), ",")

                    'データを表示

                    For j = 0 To UBound(wkbuf)

                        Cells(i + 1, j + 1) = wkbuf(j)

                    Next j

                Next i

             

            End Sub

             

            よろしければポチッと押してください

            プログラマー ブログランキングへ

             



            << | 2/6PAGES | >>

            calendar

            S M T W T F S
              12345
            6789101112
            13141516171819
            20212223242526
            2728293031  
            << May 2018 >>

            profile

            others

            mobile

            qrcode         スマホ表示に戻す