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


yositune excel VBA library



<基本操作編　その２>


Sub コメントを表示非表示() '21戻る
'コメントを表示しない、マークだけ、表示、と切り替えます
    Select Case Application.DisplayCommentIndicator
        Case xlNoIndicator
            Application.DisplayCommentIndicator = xlCommentIndicatorOnly
        Case xlCommentIndicatorOnly
            Application.DisplayCommentIndicator = xlCommentAndIndicator
        Case xlCommentAndIndicator
            Application.DisplayCommentIndicator = xlNoIndicator
        Case Else
            Application.DisplayCommentIndicator = xlNoIndicator
    End Select
End Sub

Sub カスタムフィル() '22戻る
'マウスによる面倒くさいフィルを簡単にします
'特に広範囲のフィルの威力を発揮します
    Const RorC_prompt = "フィルの方向は？　下方向は1、　右方向は 2"
    Const RorC_num_prompt = "何行、または何列まで？"
    Const FillType_prompt = "フィルの形式は？　セルのコピーは 1、　連続データは 2、　" _
        & "書式だけは 3、　値だけは 4 "
    Const RorC_title = "フィルの方向"
    Const RorC_num_title = "最終行列"
    Const FillType_title = "フィルの形式"
    Dim RorC%, RorC_num%, FillType%, nowRefStyle
    Dim R%, rs%, C%, cs%
    Dim sourceRange As Range, fillRange As Range
    
    R = Selection.Row
    rs = Selection.Rows.Count
    C = Selection.Column
    cs = Selection.Columns.Count
    Set sourceRange = Range(Cells(R, C), Cells(R + rs - 1, C + cs - 1))
    
    nowRefStyle = Application.ReferenceStyle '参照形式を保存
    Application.ReferenceStyle = xlR1C1
    RorC = Val(InputBox(RorC_prompt, RorC_title, 1))
    If RorC = 0 Then GoTo ResumeRefStyle
    
    RorC_num = Val(InputBox(RorC_num_prompt, RorC_num_title, 10))
    If RorC_num = 0 Then GoTo ResumeRefStyle
    FillType = Val(InputBox(FillType_prompt, FillType_title, 1))
    If FillType = 0 Then GoTo ResumeRefStyle
    
    Select Case FillType 'フィルのタイプ
        Case 1
            FillType = xlFillCopy
        Case 2
            FillType = xlFillDefault
        Case 3
            FillType = xlFillFormats
        Case 4
            FillType = xlFillValues
        
        Case Else
        
        Exit Sub
    End Select
    
    Select Case RorC
        Case 1 'ダウン
            If (R + rs - 1) >= RorC_num Then
                GoTo RorC_num_Error
            End If
            Set fillRange = Range(Cells(R, C), Cells(RorC_num, C + cs - 1))
            
        Case 2 'レフト
            If (C + cs - 1) >= RorC_num Then
                GoTo RorC_num_Error
            End If
            Set fillRange = Range(Cells(R, C), Cells(R + rs - 1, RorC_num))
    
    End Select
    
    sourceRange.AutoFill Destination:=fillRange, Type:=FillType
    fillRange.Select
    GoTo ResumeRefStyle
    
RorC_num_Error:
        MsgBox ("目的行または列の値が小さすぎるようです")
ResumeRefStyle:
        Application.ReferenceStyle = nowRefStyle '参照形式を戻す

End Sub

Sub シート名連続変更() '23戻る
'選択されているシートから右のシートの名前を連続して変更できます
    Const strTile = "シート名の変更"
    Const strCaption = "シート名を指定してください"
    Dim page%, pages%, n%
    Dim curPrompt$, sheet_name$
    
    page = ActiveSheet.index
    pages = ActiveWorkbook.Sheets.Count
    
    For n = page To pages
        Sheets(n).Select
        curPrompt = strCaption & Chr(13) & n & " / " & pages & "ページ"
        sheet_name = ActiveSheet.Name
        sheet_name = InputBox(curPrompt, strTile, sheet_name)
        If sheet_name = "" Then GoTo DoCancel
        ActiveSheet.Name = sheet_name
    Next n
    MsgBox "シート名変更を無事終了しました", , strTile
    Exit Sub
DoCancel:
    MsgBox "シート名変更を終了します", , strTile
End Sub

Sub A1_R1C1参照切替() '24戻る
'セルアドレスの表示を「（列）ABC...（行）123...」と「（行）123...（列）123...」の切替をします
    With Application
        If .ReferenceStyle = xlA1 Then
            .ReferenceStyle = xlR1C1
        Else
            .ReferenceStyle = xlA1
        End If
    End With
End Sub

Sub シート保護_選択セル限定() '25戻る
'enterを押すとロックされていないセルだけを選択、移動します。
'シート保護を解除するとどのセルでも選択できます。
'ただし、ブックを保存しても、次に開いたときは選択セル限定は無効になります。
    ActiveSheet.EnableSelection = xlUnlockedCells
    If ActiveSheet.ProtectContents = False Then ActiveSheet.Protect
'２重の保護は変になるので避けます
End Sub

Sub シート保護_保護解除切替() '26戻る
'シートの保護、保護解除を切り替えます
    If ActiveSheet.ProtectContents = True Then
        ActiveSheet.Unprotect
        'MsgBox "シート保護を解除しました", , "シート保護解除"
    Else
        ActiveSheet.Protect
        'MsgBox "シートを保護しました", , "シート保護"
    End If
End Sub

Sub セルロックアンロック() '27戻る
'移動セルを限定したり、セルを保護したりするときに便利です
    Dim Lock_Unlock As Boolean
    Lock_Unlock = ActiveCell.Locked
    Selection.Locked = Not (Lock_Unlock)
    Select Case Lock_Unlock
        Case True
            MsgBox ("ロック解除しました")
        Case False
            MsgBox ("ロックしました")
    End Select
End Sub

Sub シート数を知る() '28戻る
'アクティブなブックにシートがいくつあるか数えます
    Dim sheetsNum, message
    
    sheetsNum = ActiveWorkbook.Sheets.Count
    message = "このブックのシート数は　" & sheetsNum & "　です。"
    MsgBox (message)
End Sub

Sub セルの結合_解除() '29戻る
'セルの結合および解除を一発でします
    Selection.MergeCells = Not (Selection.MergeCells)
End Sub


Sub セル結合の解除() '30戻る
'セルの結合はツールボタンで簡単にできますが、面倒な解除を一発でします
'最近になって、書式コマンドにすでにあるのを発見しました。
    Selection.MergeCells = False
End Sub

Sub テキスト中央自動サイズ() '31戻る
'テキストボックスを中央揃え、自動サイズにします
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = xlHorizontal
        .AutoSize = True
    End With
End Sub

Sub ブックを保存しないで閉じて開く() '32戻る
'ブックを最後の保存した状態に戻します。
    Dim thisFileName
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    thisFileName = ActiveWorkbook.FullName
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Workbooks.Open thisFileName

End Sub

Sub ブックを保存しないで閉じる() '33戻る
'保存したくないとき、ブックを閉じるのは結構面倒です
    Application.DisplayAlerts = False
    
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

End Sub

Sub ブックを保存して閉じる() '34戻る
'保存して閉じるを一度でできます
    ActiveWorkbook.Save
    ActiveWorkbook.Close
End Sub

Sub すべてのブックを保存してエクセルを終了する() '35戻る
'パーソナルマクロのモジュールとしてだけ使えます。
'ブックを複数開いているときでも、簡単に終わることができます
    Const PMBname = "Personal.xls"
    Dim workbooksNum, macroBookname, n
    
    workbooksNum = Workbooks.Count
    
    For n = 1 To workbooksNum
        If (Workbooks(n).Name <> UCase(PMBname)) Then
            Workbooks(n).Save
            Workbooks(n).Close
        End If
    Next n
    Workbooks(PMBname).Save
    Application.Quit
End Sub

Sub 強制終了() '36戻る
'何も保存しないですぐエクセルを終了したいとき
    Application.DisplayAlerts = False
    Application.Quit
End Sub

Sub 内細点外実線() '37戻る
'選択範囲についてセルの枠を細い点線、外枠を実線、にします
    ActiveSheet.Unprotect
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlHairline
    End With
End Sub

Sub ウィンドウ最小化() '38戻る
'１つのブックで複数のウィンドウを開いている時便利です
    Dim m%, n%
    m = ActiveWorkbook.Windows.Count
    If m > 1 Then
        For n = 0 To m - 2
            ActiveWorkbook.Windows(m - n).Close
        Next n
    End If
    ActiveWindow.WindowState = xlMinimized
End Sub

Sub ウィンドウ最適化() '13戻る
  'エクセルの親ウィンドウにちょうど収まるサイズにします。
  'ウィンドウのタイトルバーをつかめないときにも便利です
  '最大化だとタイトルバーが隠れますが、これはタイトルバーが表示されます。
  With ActiveWindow
    .WindowState = xlNormal
    .Top = 0
    .Left = 0
    .Height = Application.UsableHeight + 1
    .Width = Application.UsableWidth + 1
  End With
End Sub

Sub ウィンドウを少し下げる() '14戻る
'ウィンドウのタイトルバーをつかめないときに便利です
    Dim curtop
    With ActiveWindow
        .WindowState = xlNormal
        curtop = .Top
        .Top = curtop + 20
    End With
End Sub

Sub セル移動方向切替() '39戻る
'enterキーを押してセル入力を確定したら、次に選択されるセルは下か、右か
    Select Case Application.MoveAfterReturnDirection
        Case xlToRight
            Application.MoveAfterReturnDirection = xlDown
        Case xlDown
            Application.MoveAfterReturnDirection = xlToRight
    End Select
End Sub

Sub ブック内全シートから検索() '40戻る
'目的の文字列を、ブック内の（非表示でない）全シートから検索します
'見つかったセルの文字に色を付けて分かりやすくします。
'これを別名で保存します（元のブックは変更されません）
'必要な場合は、元のブックを事前に保存しておいてください

    Const COLORNUM = 4 '見つけたセルの文字色
    Const COLORITEMS = "3（赤） 4（緑） 5（青） 6（黄）" '色を選べるようにします
    Dim targetStr$, newColor
    Dim foundcell_1 As Range
    Dim foundcell As Range
    Dim pages%, n%, cellsnum%
    Dim thisFileName$, newFileName
    Dim theOKCancel%
    
    targetStr = InputBox("検索文字列？", "全シート検索")
    If targetStr = "" Then Exit Sub
    newColor = InputBox("検索された文字色？" & Chr(13) & COLORITEMS, "全シート検索", COLORNUM)
    If newColor = "" Then newColor = COLORNUM
    pages = ActiveWorkbook.Worksheets.Count
    cellsnum = 0
    
    For n = 1 To pages
        If Worksheets(n).Visible = True Then
            Set foundcell_1 = Worksheets(n).Cells.Find(What:=targetStr, _
            LookIn:=xlFormulas, LookAt:=xlWhole)
            If Not (foundcell_1 Is Nothing) Then
                Worksheets(n).Select
                Worksheets(n).Unprotect
                foundcell_1.Select
                With Selection.Font
                    .ColorIndex = newColor
                    .Bold = True
                End With
                theOKCancel = MsgBox(targetStr & Chr(13) & Chr(13) & " --を検索中--" & Chr(13) & Chr(13) & cellsnum + 1 & "個め", vbOKCancel, "見つかりました!")
                If theOKCancel = vbCancel Then GoTo exitfind 'キャンセルの場合中止します
                cellsnum = cellsnum + 1
                
                Set foundcell = Worksheets(n).Cells.FindNext(After:=foundcell_1)
                Do While Not (foundcell.Address = foundcell_1.Address) '.Addressが必要
                    foundcell.Select
                    With Selection.Font
                        .ColorIndex = newColor
                        .Bold = True
                    End With
                    theOKCancel = MsgBox(targetStr & Chr(13) & Chr(13) & " --を検索中--" & Chr(13) & Chr(13) & cellsnum + 1 & "個め", vbOKCancel, "見つかりました!")
                    If theOKCancel = vbCancel Then GoTo exitfind 'キャンセルの場合中止します
                    cellsnum = cellsnum + 1
                    Set foundcell = Worksheets(n).Cells.FindNext(After:=foundcell)
                Loop
            End If
        End If
    
    Next n
    If cellsnum = 0 Then MsgBox "見つかりませんでした"
        If cellsnum > 0 Then
        MsgBox "以上です。合計" & cellsnum & "個見つかりました。", , "検索結果"
        thisFileName = ActiveWorkbook.Name
' thisFileName = Left(thisFileName, Len(thisFileName) - 4) & "2"
        If InStr(1, thisFileName, ".") > 0 Then '拡張子削除
            thisFileName = Left(thisFileName, Len(thisFileName) - 4)
        End If
        thisFileName = thisFileName & targetStr
        newFileName = Application.GetSaveAsFilename(InitialFilename:=thisFileName, Title:="検索結果を別名で保存します", _
        filefilter:="Microsoft Excel ﾌﾞｯｸ(*.xls),*xls")
        If newFileName <> False Then
            ActiveWorkbook.SaveAs FileName:=newFileName, FileFormat:=xlNormal
        End If
    End If
    
exitfind:
    Exit Sub
End Sub

Sub 斜め参照() '41戻る
'１行のセルを列に参照させる場合に使います。
'例えば、１０行のA列からF列までに各列の合計を出すようにしていて、
'その合計結果を、G列の１行から６行までに表示させたい場合に使います。
'行を別な行に、または列を別な列に、というのはドラッグで簡単にできます。
'しかし、行を列に、列を行に、という場合は１つ１つのセルに式を入れてやらなければならず、大変面倒です。
'このマクロは、別なシートやブックを参照する場合でも使えます。
'関数編の関数を使いますので、合わせてコピーしておいてください。
'<<最近、TRANSPOSE関数を使って同様のことができることを発見しました。(2001/1/22)
'<<しかし、配列入力だとか、変更しにくいとか、問題もあります。
'<<使いやすい方を使ってみてください。

    Dim theformula$, equal_sheetname$, numExcl%, numR%, numC%, R%, C%, fR%, fC%
    Dim gyoretu, repeat_count, prompt$, answer$
    Dim curReferenceStyle&
    Dim n%
    
    R = ActiveCell.Row
    C = ActiveCell.Column
    
    curReferenceStyle = Application.ReferenceStyle
    Application.ReferenceStyle = xlR1C1 'R1C1参照表示にする
    prompt = "参照元を下へ移動しながら右へ、または参照元を右へ移動しながら下へ、" & _
    "斜め参照します。最初の参照式のあるセルを選択してください。" & _
    "今選択しているセルに、参照式が入力されていますか？"
    answer = MsgBox(prompt, vbOKCancel)
    If answer = vbCancel Then Exit Sub
    
    prompt = "列を参照するよう行に入力していくなら、0。" & _
    "逆なら、1"
    gyoretu = InputBox(prompt, , 0)
    If gyoretu = "" Then Exit Sub
    
    theformula = ActiveCell.FormulaR1C1
    numExcl = InStr(theformula, "!")
    numR = InStr(Right(theformula, Len(theformula) - numExcl), "R") + numExcl
    numC = InStr(Right(theformula, Len(theformula) - numR), "C") + numR
    
    equal_sheetname = Left(theformula, numR - 1)
    fR = FGetLongValFromString(Mid(theformula, numR, numC - numR))
    fC = FGetLongValFromString(Mid(theformula, numC, Len(theformula) - numC + 1))
    Select Case gyoretu
        Case 0
            prompt = "何列まで？"
        Case 1
            prompt = "何行まで？"
    End Select
    repeat_count = InputBox(prompt, , 10)
    If repeat_count = "" Then Exit Sub
    Select Case gyoretu
        Case 0
            For n = C + 1 To repeat_count
                fR = fR + 1
                fC = fC - 1
                
                theformula = equal_sheetname & "R[" & fR & "]C[" & fC & "]"
                Cells(R, n).Formula = theformula
            Next n
        Case 1
            For n = R + 1 To repeat_count
                fR = fR - 1
                fC = fC + 1
                
                theformula = equal_sheetname & "R[" & fR & "]C[" & fC & "]"
                Cells(n, C).Formula = theformula
            Next n
    End Select
    Application.ReferenceStyle = curReferenceStyle
End Sub


トップページへ戻る