[TOP][基本操作] [関数] [お遊び] [マクロを登録][ユーザー定義表示形式][自作メニュー]


yositune excel VBA library



<基本操作編　その１>

Dim MyData As New DataObject '「選択範囲を値_書式_セル形コピー 、ペースト」に必要です
Sub ブック切り替え() '1戻る
'２つ以上のブックを開いている時アクティブになっているブックを切り替えます
'ウィンドウメニューで切り替える面倒くささが解消されます
'メニューバー、ツールバーにこのマクロを登録したボタンを作ると、快適です
    Dim bookscount%, n%, w As Window
    Dim workbookvisible As Boolean
    
    bookscount = Application.Workbooks.Count
    For n = 1 To bookscount
        'アクティブブックのインデックスをつかみ、一つ進める
        If Workbooks(n) Is ActiveWorkbook Then
            Do 'ただし非表示のブックは無視する
                n = n + 1
                If n > bookscount Then n = 1
                workbookvisible = False
                For Each w In Workbooks(n).Windows
                    workbookvisible = workbookvisible Or w.Visible
                Next w
            Loop While Not (workbookvisible)
            Exit For
        End If
    Next n
wakatta: '当該ブックの表示ウィンドウを順にアクティブにする
    For Each w In Workbooks(n).Windows
        If w.Visible = True Then w.Activate
    Next w
End Sub

Sub メニューバーに日付() '2戻る
    'メニューバーに今日の日付を表示させます
    '例えば次のようにパーソナルマクロブックの「ThisWorkbook」オブジェクトに起動時のマクロとして設定します
' Private Sub Workbook_Open()
' メニューバーに日付
' End Sub
    Const DATEPARAM = "datemenu" 'だぶらないで、上書きしていくようにParameterプロパティでつかみます
    Dim datemenu, cntrl
    
    For Each cntrl In CommandBars("Worksheet Menu Bar").Controls
        If cntrl.Parameter = DATEPARAM Then
            cntrl.Delete '古いものを削除する
        End If
    Next cntrl
    
    Set datemenu = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
    datemenu.Caption = Format(Date, "m月" & "d日（aaa）") '今日の日付と曜日を表示させる
    datemenu.Parameter = DATEPARAM
End Sub

Sub 印刷1から3ページまで2枚ずつ() 'EasyPrintの使用例'3戻る
    EasyPrint , 3, 2
End Sub

Sub EasyPrint(Optional from_p = 1, Optional to_p = 1, Optional maisu = 1)戻る
    '印刷の際、引数を省略できます
    '各種の印刷方法をマクロにするとき便利です
    '第１ページを１枚がデフォルトです
    ActiveSheet.PrintOut From:=from_p, To:=to_p, _
            copies:=maisu, Collate:=True
End Sub

Sub 標準表示形式() '4戻る
    'セルの表示形式を標準に戻します
    Selection.NumberFormatLocal = "G/標準"
End Sub

Sub 表示形式日付() '5戻る
'セルの表示形式を「1/22 (月)」型の日付にします
Selection.NumberFormatLocal = "m/d (aaa)"
End Sub

Sub test空白行非表示()戻る
    '「F空白行非表示」関数テスト用のSubです
    Dim a
    
    a = F空白行非表示(ActiveSheet, 2, 1, 20)
    MsgBox a & "行を非表示にします"
End Sub

Function F空白行非表示(ByVal theSheet As Object, theColumn%, startRow%, endRow%) As Long '6戻る
'theSheetワークシートの、theColumn列について
'startRow行からendRow行までを調べ、0または空白の行を非表示にします
'少し手を加えると列の非表示にも使えます
'2006/4/18変更
    Dim m&, cellsval, targetRows As Range, counter&
    
    Application.ScreenUpdating = False '画面の動きを一時中断します
    'いったんすべての行を表示します
    theSheet.Range(Cells(startRow, 1), Cells(endRow, 1)).EntireRow.Hidden = False
    For m = startRow To endRow
        cellsval = Format(theSheet.Cells(m, theColumn).Value, "#")
        If cellsval = "" Then
            If targetRows Is Nothing Then
                Set targetRows = theSheet.Rows(m)
            Else
                Set targetRows = Union(targetRows, theSheet.Rows(m))
            End If
            counter = counter + 1
        End If
    Next m
' End If
    F空白行非表示 = counter '非表示行数を返します
    If Not (targetRows Is Nothing) Then
        targetRows.EntireRow.Hidden = True
    End If
End Function

Sub test空白列非表示()戻る
    '「F空白列非表示」関数テスト用のSubです
    Dim a
    
    a = F空白列非表示(ActiveSheet, 2, 1, 20)
    MsgBox a & "列を非表示にします"
End Sub

Function F空白列非表示(ByVal theSheet As Object, theRow%, startColumn%, endColumn%) As Long '6戻る
'theSheetワークシートの、theRo行について
'startColumn列からendColumn列までを調べ、0または空白の列を非表示にします
'2006/8/19
    Dim m&, cellsval, targetColumns As Range, counter&
    
' Application.ScreenUpdating = False '画面の動きを一時中断します
    'いったんすべての列を表示します
    theSheet.Range(Cells(1, startColumn), Cells(1, endColumn)).EntireColumn.Hidden = False
    For m = startColumn To endColumn
        cellsval = Format(theSheet.Cells(theRow, m).Value, "#")
        If cellsval = "" Then
            If targetColumns Is Nothing Then
                Set targetColumns = theSheet.Columns(m)
            Else
                Set targetColumns = Union(targetColumns, theSheet.Columns(m))
            End If
            counter = counter + 1
        End If
    Next m
' End If
    F空白列非表示 = counter '非表示列数を返します
    If Not (targetColumns Is Nothing) Then
        targetColumns.EntireColumn.Hidden = True
    End If
End Function

Sub データフォーム表示() '7戻る
'組み込みのデータフォームを呼び出します
    ActiveSheet.ShowDataForm
End Sub

Sub 本日更新ファイルを_曜日フォルダに保存() '8戻る
    'SaveUpdateFilesToBackupDir_fsobjectを呼び出します。ファイルが開いている状態でもバックアップ保存できます。
    'Personal.xlsのWorkbook_BeforeCloseで実行するようにすると楽々です（Excel97）
    'Excel2000,2003ではエクセルを終了した場合、Personal.xlsのWorkbook_BeforeCloseイベントが呼び出されないようです
    'その場合、Personal.xlsのWorkbook_BeforeCloseで呼び出すのはあきらめます。
    'auto_closeという手もありますが、、、、、
    'Personal.xlsと同じXLSTARTフォルダに適当なブック（例えばsub_P.xls）を作り、そのブックのWorkbook_BeforeCloseイベントから呼び出します
    'そこに　Application.Run "PERSONAL.XLS!本日更新ファイルを_曜日フォルダに保存"　と書いてください
    '2006/4/18更新
    Const SOURCEDIR_C = "C:\My Documents" '元のファイルがあるフォルダ（適当に変更）
    Const SOURCEDIR_D = "D:\D_Mydocument" '元のファイルがあるフォルダ（適当に変更）
    Const STOCKDIR = "E:\Backup" 'バックアップコピーを保存する曜日フォルダを作る上部フォルダ（必ず事前に作っておいてください）
    
    '２つのフォルダーからバックアップする例
    SaveUpdateFilesToBackupDir_fsobject SOURCEDIR_C, STOCKDIR
    SaveUpdateFilesToBackupDir_fsobject SOURCEDIR_D, STOCKDIR
    
End Sub

Function SaveUpdateFilesToBackupDir_fsobject(sourcedir$, destdir$) As Long '8-1戻る
    '今日更新したファイルを今日の曜日のフォルダー(たとえば火曜日)に保存します。
    'いつでも1週間前のファイルに戻れるので、ファイルに書き損ねたり、壊れたりしたときに便利です。
    '01から31日までの日ごとのフォルダーに保存するオプションも用意してあります。この場合1月前まで戻れることになります。
    '日々更新する業務用ファイルのバックアップに便利だと思います。
    Const FILEMAX = 100 '保存するファイルの上限(適当に変更してください）
    Dim fdtime, strCurfilename$, strsoucefilepath$, strdestfilepath, strToday$
    Dim strCurDir$, strCurDrive$, strOldDir$, strOldDrive$, strDestDir$
    Dim f&, n&, m&
    Dim strNewFile(FILEMAX - 1) As String
    Dim fs
    On Error Resume Next
    strToday = Format(Date, "yyyy/mm/dd") '今日の日付
    strDestDir = destdir & "\" & Format(Date, "aaaa") & "\" '*曜日のフォルダにバックアップする
' strDestDir = DESTDIR & "\" & Format(Date, "dd") & "\" '**日のフォルダにバックアップする場合は上の行をコメントにし、この行を生かす
    strOldDir = CurDir '現在のカレントディレクトリを保存
    strOldDrive = Left(strOldDir, 1) '現在のカレントドライブを保存
    ChDrive Left(sourcedir, 1) '元のファイルがあるドライブをカレントにする
    ChDir sourcedir '元のファイルがあるフォルダをカレントにする,Dir関数を使うために
    If Err.Number > 0 Then
        MsgBox sourcedir & "について" & Error(Err.Number)
        GoTo notfinddir
    End If
    
    f = 0
    strCurDir = sourcedir & "\"
    strCurfilename = Dir(strCurDir) 'カレントフォルダで最初に見つかったファイル
    Do While Len(strCurfilename) > 0 'ファイルがある限り
        fdtime = FileDateTime(strCurfilename) 'ファイルの更新日を取得
        If strToday = Format(fdtime, "yyyy/mm/dd") Then '2002/03/03風の日付形式で今日の更新と判断したら
            strNewFile(f) = strCurfilename 'ファイル名を配列に加える
            f = f + 1
            If f = FILEMAX Then
                MsgBox "保存対象ファイルが上限数" & FILEMAX & "を超えました" & Chr(13) & _
                    "必要なら上限数を設定し直してください"
                Exit Do
            End If
        End If
        strCurfilename = Dir 'カレントフォルダで次に見つかったファイル
    Loop
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FolderExists(Left(strDestDir, Len(strDestDir) - 1)) = False Then '*曜日のフォルダがなければ
        MkDir Left(strDestDir, Len(strDestDir) - 1) '*曜日のフォルダを作る
    End If
    If Err.Number > 0 Then 'フォルダーが作れないエラー
        MsgBox "フォルダー " & Left(strDestDir, Len(strDestDir) - 1) _
            & "が作れません " & destdir & "はありますか？" & Chr(13) & _
            "バックアップできないまま終了します"
        GoTo notmakedir
    End If
    
    For m = 0 To f - 1 '今日更新されたすべてのファイルについて
        strsoucefilepath = strCurDir & strNewFile(m) '元のファイルのパス
        strdestfilepath = strDestDir & strNewFile(m) 'バックアップコピーを保存する際のパス
        Err.Clear
        fs.CopyFile strsoucefilepath, strdestfilepath, True
        If Err.Number > 0 Then 'エラーの場合
            MsgBox strNewFile(m) & "について:" & Chr(13) & (Error(Err.Number)) 'エラーメッセージ
        End If
    Next m
    
notmakedir:
notfinddir:
    ChDrive strOldDrive 'カレントドライブを元に戻す
    ChDir strOldDir 'カレントディレクトリを元に戻す
    SaveUpdateFilesToBackupDir_fsobject = Err.Number
End Function

Sub 選択範囲を値_書式_セル形コピー() '選択範囲を値_書式_セル形ペーストと組み合わせて使います'9戻る
  Dim heightArrayText As String
  Dim widthArrayText As String
  Dim rs, cs, n, go_or_not
  
  rs = Selection.Rows.Count
  cs = Selection.Columns.Count
  If rs > 1000 Then '1000行を超える場合は警告
    go_or_not = MsgBox("範囲が広すぎます、時間がかかりますよ？" _
        & Chr(13) & "それでも続けますか？", vbOKCancel + vbDefaultButton2 _
        , "範囲警告")
    If go_or_not = vbCancel Then Exit Sub
  End If
  
  heightArrayText = "" '行の幅
  For n = 1 To rs
    heightArrayText = heightArrayText & Selection.Rows(n).RowHeight & ","
  Next n
  
  widthArrayText = "" '列の高さ
  For n = 1 To cs
    widthArrayText = widthArrayText & Selection.Columns(n).ColumnWidth & ","
  Next n
  
' Set MyData = New DataObject
  'データを格納
  MyData.SetText heightArrayText, 100
  MyData.SetText rs, 101
  MyData.SetText widthArrayText, 102
  MyData.SetText cs, 103
  
  Selection.Copy '選択範囲をコピー
  
End Sub

Sub 選択範囲を値_書式_セル形ペースト() '選択範囲を値_書式_セル形コピーと組み合わせて使います'10戻る
  Dim heightArray()
  Dim widthArray()
  Dim n
  
  Application.ScreenUpdating = False
  '値ペースト
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
  '書式ペースト
  Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
  Application.CutCopyMode = False
  
  ReDim heightArray(Val(MyData.GetText(101)))
  ReDim widthArray(Val(MyData.GetText(103)))
  'セル形データを取り出して、配列に収納
  MakeMyArray heightArray, MyData.GetText(100)
  MakeMyArray widthArray, MyData.GetText(102)
  '適用する
  For n = 1 To Selection.Rows.Count '行の高さ
    Selection.Rows(n).RowHeight = heightArray(n - 1)
  Next n
  For n = 1 To Selection.Columns.Count '列の幅
    Selection.Columns(n).ColumnWidth = widthArray(n - 1)
  Next n
  'DataObjectを消す
  MyData.SetText "", 100
  MyData.SetText "", 101
  MyData.SetText "", 102
  MyData.SetText "", 103
End Sub

Private Function MakeMyArray(ByRef destArray(), ByVal sourceText)
'テキスト（コンマ）から配列へ格納する
  Dim n, comma1, comma2, index
  comma1 = 0
  index = 0
  For n = 1 To Len(sourceText)
    If Mid(sourceText, n, 1) = "," Then
      comma2 = n
      destArray(index) = Val(Mid(sourceText, comma1 + 1, comma2 - comma1 - 1))
      comma1 = comma2
      index = index + 1
    End If
  Next n
End Function

Sub 選択範囲をコピーして新規ブックに値_書式ペースト() '11戻る
'選択範囲のデータを、元データをそのままにして、加工するときに使えます。
'値、書式、ついでにセルの高さ、幅も同じにします
  選択範囲を値_書式_セル形コピー
  Workbooks.Add
  選択範囲を値_書式_セル形ペースト
End Sub

Sub 選択セル合計値をコピー() '12戻る
'選択されたセルの値の合計をクリップボードにコピーします。
'他のセルにペーストすると、その合計数値が入ります。
  Dim MyData As DataObject
  
  Set MyData = New DataObject
  'テキスト形式でコピー
  MyData.SetText Application.WorksheetFunction.Sum(Selection), 1
  MyData.PutInClipboard
End Sub

Sub セルを結合して横標準_縦上_折り返し()戻る
  
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .MergeCells = True
    End With
End Sub

Sub 折り返し表示_取り消し() '15戻る
'折り返して全体を表示したり、逆に折り返さないようにしたりします
    Selection.WrapText = Not (Selection.WrapText)
End Sub

Sub ステータスバーONOFF() '16戻る
'日頃は画面を狭くする邪魔なステータスバーを表示したり、隠したりします
'選択セルの合計値を表示してくれる便利な機能を使いたいときがあります
    If Application.DisplayStatusBar = False Then
        ActiveSheet.Unprotect 'シート保護は解除します
        'セルを選択できない場合がありますので
    End If
    Application.DisplayStatusBar = Not (Application.DisplayStatusBar)
End Sub

Sub 丸みのある長方形新規作成() '17戻る
'マクロボタンを作るときに便利ですよ
'テキスト編集がしやすいように、デフォルトで「テキスト」と表示させます。
'選択したセルの位置に作成します
    Const kColor = 42 '薄緑（適当に変更してください）
    Const kWidth = 56.5
    Const kHeight = 35 '黄金分割です（適当に変更してください）
    
    Dim intleft%, inttop%
    
    ActiveSheet.Unprotect
    
    intleft = ActiveCell.Left
    inttop = ActiveCell.Top
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, intleft, inttop, kWidth, kHeight).Select
    With Selection
        .Characters.Text = "テキスト"
        .HorizontalAlignment = xlCenter '水平中央
        .VerticalAlignment = xlCenter '上下中央
        .Orientation = xlHorizontal
        .Placement = xlMove
        .PrintObject = False
        .ShapeRange.Shadow.Type = msoShadow14 '影をつけます
        .ShapeRange.Fill.ForeColor.SchemeColor = kColor
        With .Font
          .Name = "ＭＳ Ｐゴシック"
          .Bold = True 'ボールド
          .Size = 11
        End With
    End With
End Sub

Sub セル高さ幅をそろえる() '18戻る
'選択したセルの高さ幅にワークシート全体を揃えます
    Cells.RowHeight = ActiveCell.RowHeight
    Cells.ColumnWidth = ActiveCell.ColumnWidth
End Sub

Sub セルの高さと幅を取替える() '19戻る
'選択したセルの幅を高さにし
'高さを幅にします
    Dim oldWidh, letter_per_point
    
    oldWidh = ActiveCell.Width
    letter_per_point = ActiveCell.ColumnWidth / ActiveCell.Width
    
    With Cells '幅と高さで単位が違うので、手作業だと難しい
        .ColumnWidth = letter_per_point * ActiveCell.Height
        .RowHeight = oldWidh
    End With
End Sub

Sub 正方形セル() '20戻る
'選択したセルの幅に合わせてワークシート全体のセルを正方形に揃えます
    With Cells '幅と高さで単位が違うので、手作業だと難しい
        .ColumnWidth = ActiveCell.ColumnWidth
        .RowHeight = ActiveCell.Width
    End With
End Sub


トップページへ戻る