2013 個人用マクロ

こつこつためていこう。

Option Explicit

' 非表示のシートに対してSelectすると
' 「実行時エラー '1004' Worksheet クラスの Select メソッドが失敗しました。」
' が起きる。ただし面倒くさいから一部しか対応していない。

Private Sub FindActualEnd(outLastRow As Long, outLastCol As Long, outActualRow As Long, outActualCol As Long)

    Dim lastCell As Range   ' Excel的最終セル
    Dim lastRow As Long     ' Excel的最終行
    Dim lastCol As Long     ' Excel的最終列
    Dim formulaRow As Long  ' 式が入っている最終行(セルの結合のせいか知らんが微妙に信用できない)
    Dim formulaCol As Long  ' 式が入っている最終列(セルの結合のせいか知らんが微妙に信用できない)
    Dim actualRow As Long   ' 人間的最終行
    Dim actualCol As Long   ' 人間的最終列
    Dim maxRow As Long      ' ループ処理の上限 行
    Dim maxCol As Long      ' ループ処理の上限 列
    Dim minRow As Long      ' ループ処理の下限 行
    Dim minCol As Long      ' ループ処理の下限 列
    Dim r As Long           ' ループカウンタ 行
    Dim c As Long           ' ループカウンタ 列
    Dim foundRange As Range
    Dim borderItem As Border
    Dim shapeItem As Shape
    Dim shapeItemRange As Range
    Dim isFound As Boolean
    
    ActiveSheet.UsedRange ' 最終行更新(これでファイルを保存して開きなおさなくて良いらしい)
    Set lastCell = ActiveCell.SpecialCells(xlLastCell)
    lastRow = lastCell.Row
    lastCol = lastCell.Column
    formulaRow = 1
    formulaCol = 1
    Set foundRange = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
    If Not foundRange Is Nothing Then
        formulaRow = foundRange.Row
        formulaCol = foundRange.Column
    End If
    Set foundRange = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
    If Not foundRange Is Nothing Then
        formulaCol = foundRange.Column
    End If
    
    
    ' 罫線があるセルの検索でエラーになるのを解決できずループで探す
    
    ' 検索対象が多いとべらぼーに時間がかかるので、上限下限を切る
    maxRow = lastRow
    If formulaRow + 100 < lastRow Then
        maxRow = formulaRow + 100
    End If
    maxCol = lastCol
    If formulaCol + 100 < lastCol Then
        maxCol = formulaCol + 100
    End If
    minRow = 1 ' スペースのみのセルを無視するため何か入っているセルより手前に設定する
    If 1 < formulaRow - 100 Then
        minRow = formulaRow - 100
    End If
    minCol = 1
    If 1 < formulaCol - 100 Then
        minCol = formulaCol - 100
    End If
    
    ' 最終行を探す
    isFound = False
    actualRow = formulaRow
    actualCol = formulaCol
    For r = maxRow To minRow Step -1
        For c = maxCol To 1 Step -1
            With Cells(r, c)
                If Trim(.Formula) <> "" _
                Or .Interior.ColorIndex <> xlNone Then
                    actualRow = r
                    If actualCol < c Then
                        actualCol = c
                    End If
                    isFound = True
'                    Debug.Print r
'                    Debug.Print .Interior.ColorIndex
                    Exit For
                Else
                    For Each borderItem In .Borders
                        If borderItem.LineStyle <> xlLineStyleNone Then
                            actualRow = r
                            If actualCol < c Then
                                actualCol = c
                            End If
                            isFound = True
                            Exit For
                        End If
                    Next
                End If
            End With
            If isFound Then
                Exit For
            End If
        Next
        If isFound Then
            Exit For
        End If
    Next
    
    ' 最終列を探す
    minCol = actualCol ' 先のループでヒットしてるかもしれないから
    isFound = False
    For c = maxCol To minCol Step -1
        For r = actualRow To 1 Step -1
            With Cells(r, c)
                If Trim(.Formula) <> "" _
                Or .Interior.ColorIndex <> xlNone Then
                    actualCol = c
                    isFound = True
                    Exit For
                Else
                    For Each borderItem In .Borders
                        If borderItem.LineStyle <> xlLineStyleNone Then
                            actualCol = c
                            isFound = True
                            Exit For
                        End If
                    Next
                End If
            End With
            If isFound Then
                Exit For
            End If
        Next
        If isFound Then
            Exit For
        End If
    Next

    For Each shapeItem In ActiveSheet.Shapes
        Set shapeItemRange = shapeItem.BottomRightCell
        If shapeItemRange.Row > actualRow Then
            actualRow = shapeItemRange.Row
        End If
        If shapeItemRange.Column > actualCol Then
            actualCol = shapeItemRange.Column
        End If
        If shapeItemRange.Row > lastRow Then
            lastRow = shapeItemRange.Row
        End If
        If shapeItemRange.Column > lastCol Then
            lastCol = shapeItemRange.Column
        End If
    Next
    
'    If actualRow < lastRow Then
'        actualRow = actualRow + 1
'    End If
'    If actualCol < lastCol Then
'        actualCol = actualCol + 1
'    End If
    'Cells(actualRow, actualCol).Select
    outLastRow = lastRow
    outLastCol = lastCol
    outActualRow = actualRow
    outActualCol = actualCol
    
End Sub

Public Sub FollowHyperink()
    On Error Resume Next
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End Sub

Public Sub JumpFirstSheet()
    Sheets(1).Activate
End Sub

Public Sub JumpLastSheet()
    Sheets(Sheets.Count).Activate
End Sub

Public Sub JumpNextSheet()
    On Error Resume Next
    'ActiveSheet.Next.Select
    If ActiveSheet.Next.Visible = xlSheetHidden Then
        Call JumpNextSheetAt(ActiveSheet.Next)
    Else
        ActiveSheet.Next.Activate
    End If
   
End Sub

Private Sub JumpNextSheetAt(currentSheet As Object)
    If currentSheet.Next.Visible = xlSheetHidden Then
        Call JumpNextSheetAt(currentSheet.Next)
    Else
        currentSheet.Next.Activate
    End If
End Sub

Public Sub JumpPreviousSheet()
    On Error Resume Next
    'ActiveSheet.Previous.Select
    If ActiveSheet.Previous.Visible = xlSheetHidden Then
        Call JumpPreviousSheetAt(ActiveSheet.Previous)
    Else
        ActiveSheet.Previous.Activate
    End If
End Sub

Private Sub JumpPreviousSheetAt(currentSheet As Object)
    If currentSheet.Previous.Visible = xlSheetHidden Then
        Call JumpPreviousSheetAt(currentSheet.Previous)
    Else
        currentSheet.Previous.Activate
    End If
End Sub

Public Sub ResetView()
    ResetViewWithOption False
End Sub

Public Sub ResetViewNoGrid()
    ResetViewWithOption True
End Sub

Private Sub ResetViewWithOption(hideGrid As Boolean)
    Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Visible <> xlSheetHidden Then
            Sheets(i).Select
            Range("A1").Select
            ActiveWindow.View = xlNormalView
            ActiveWindow.Zoom = 100
            If hideGrid Then
                ActiveWindow.DisplayGridlines = False
            End If
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
        End If
    Next
    Sheets(1).Activate
End Sub

Public Sub SelectEnd()
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long
    Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Visible <> xlSheetHidden Then
            Sheets(i).Select
            ActiveWindow.View = xlNormalView
            ActiveWindow.Zoom = 60
            'Range("A1").Select
            'ActiveCell.SpecialCells(xlLastCell).Select
            Call FindActualEnd(lastRow, lastCol, r, c)
            If r < lastRow Then
                r = r + 1
            End If
            If c < lastCol Then
                c = c + 1
            End If
            Cells(r, c).Select
        End If
    Next
    Sheets(1).Activate
End Sub

Public Sub SelectTop()
    Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Visible <> xlSheetHidden Then
            Sheets(i).Select
            Range("A1").Select
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
        End If
    Next
    Sheets(1).Activate
End Sub

' 使わないけどせっかくなのでPrivateにして置いておく
Private Sub SelectWorkSheetsAll()

    Dim sheetList() As String
    ReDim sheetList(Sheets.Count - 1)
    Dim idx As Integer
    idx = 0
    sheetList(idx) = ActiveSheet.Name

    Dim item As Worksheet
    For Each item In Sheets
        If item.Visible = xlSheetVisible And item.Name <> sheetList(0) Then
            idx = idx + 1
            sheetList(idx) = item.Name
        End If
    Next

    ReDim Preserve sheetList(idx)
    Sheets(sheetList).Select

End Sub

Public Sub ShowWorkSheetsList()
    If Sheets.Count >= 16 Then
        If Application.CommandBars("workbook tabs").Controls(16).Caption Like "シートの選択*" Then
            Application.SendKeys "{END}~"
        End If
    End If
    Application.CommandBars("workbook tabs").ShowPopup
End Sub

Public Sub ShrinkBlankCell()

    Dim msgBoxResult As Long
    msgBoxResult = MsgBox("無駄っぽいセルを消すよ。" & vbCrLf & "後戻りできないよ？", vbYesNo + vbDefaultButton2 + vbInformation, "実行確認")
    If msgBoxResult <> vbYes Then
        Exit Sub
    End If
    
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long
    Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Visible <> xlSheetHidden Then
            Sheets(i).Select
            ActiveWindow.View = xlNormalView
            ActiveWindow.Zoom = 60
            Call FindActualEnd(lastRow, lastCol, r, c)
            If r < lastRow Then
                Range(r + 1 & ":" & lastRow).Delete
            End If
            If c < lastCol Then
                Range(Cells(1, c + 1), Cells(1, lastCol)).EntireColumn.Delete
            End If
            Sheets(i).UsedRange ' 最終行更新(これでファイルを保存して開きなおさなくて良いらしい)
            ActiveCell.SpecialCells(xlLastCell).Select
        End If
    Next
    Sheets(1).Activate

End Sub

' 各シートをズームする
Public Sub ZoomHorizontalStretchNoGrid()
    Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Visible <> xlSheetHidden Then
            Sheets(i).Select
            ActiveWindow.View = xlNormalView
            ActiveWindow.DisplayGridlines = False
            
            Sheets(i).UsedRange ' 最終行更新(これでファイルを保存して開きなおさなくて良いらしい)
            ActiveCell.SpecialCells(xlLastCell).Select
            Range(Selection, Cells(ActiveCell.Row, 1)).Select
            ActiveWindow.Zoom = True
            
            Range("A1").Select
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
        End If
    Next
    Sheets(1).Activate
End Sub