[Excel]実用(?)マクロ集

Sub CopyAsPicture()
    Dim tempBoolean As Boolean
    tempBoolean = ActiveWindow.DisplayGridlines
    ActiveWindow.DisplayGridlines = False
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ActiveWindow.DisplayGridlines = tempBoolean
End Sub

Function Vlookup2(SA As Range, col As Integer, ParamArray cond() As Variant) As Variant
    Dim a As Range, r As Range
    Dim count As Integer, c As Variant, check As Boolean
    For Each a In SA.Areas
        For Each r In a.Rows
            count = 1: check = True
            For Each c In cond()
                If r.Columns(count) Like c Then
                    count = count + 1
                Else
                    check = False: Exit For
                End If
            Next c
            If check Then Vlookup2 = r.Columns(col): Exit Function
        Next r
    Next a
    Vlookup2 = 0
End Function

    =VlookUp2(B2:E5,4,"7","Wed")

Function VlookArea(str As String, SA As Range, Optional col As Integer = 1) As Range
    Dim temp As Range, a As Range, r As Range
    Set temp = Nothing
    For Each a In SA.Areas
        For Each r In a.Rows
            If str Like r.Columns(col).Value Then
                If temp Is Nothing Then
                    Set temp = r
                Else
                    Set temp = Union(temp, r)
                End If
            End If
        Next r
    Next a
    Set VlookArea = temp
End Function

    VlookArea("test",Range("B2:E5"),2).select

Function SumColor(rngSelect As Range, intColor As Integer) As Double
    Dim a As Range, r As Range, sum As Double
    sum = 0#
    For Each a In rngSelect.Areas
        For Each r In a.Cells
            If r.Interior.ColorIndex = intColor And IsNumeric(r) = True Then sum = sum + r
        Next r
    Next a
    SumColor = sum
End Function

    =SUMCOLOR(A1:A5,3)

Function RowDoubling(Optional DoubleNum As Integer = 0, Optional Target As Range = Nothing) As Range
    On Error GoTo ErrorRowDoubling
    Dim i As Integer, j As Integer, RowNum As Integer, r As Range
    If Target Is Nothing Then Set Target = Selection
    If DoubleNum = 0 Then DoubleNum = CInt(InputBox("何倍にしますか?", , "2"))
    RowNum = Target.Rows.count
    If RowNum * DoubleNum > Target.Parent.Rows.count Or DoubleNum < 2 Then
        Set RowDoubling = Target
    Else
        Application.ScreenUpdating = False
        Set r = Target.Rows(1)
        For i = 1 To RowNum
            For j = 2 To DoubleNum
                r.Copy
                r.Insert Shift:=xlShiftDown
            Next j
            Set r = r.Offset(1, 0)
        Next i
        Set RowDoubling = Range(Target.Rows(1).Offset(-DoubleNum + 1, 0), r.Offset(-1, 0))
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
    Exit Function
ErrorRowDoubling:
    Set RowDoubling = Target
    On Error GoTo 0
End Function

    RowDoubling(3).select

Sub DispSpecialCell()
    On Error Resume Next
    Application.Dialogs(xlDialogSelectSpecial).Show
    On Error GoTo 0
End Sub

Sub Kakko(Optional Target As Range = Nothing, Optional OP As String = "(", Optional CL As String = ")")
    On Error GoTo KakkoError
    Dim a As Range, r As Range, StdFont As Font
    If Target Is Nothing Then Set Target = Selection
    For Each a In Target.Areas
    For Each r In a.Cells
        With r.Characters(1, 1)
            .Insert OP & .Text
        End With
        With r.Characters(r.Characters.count, 1)
            .Insert .Text & CL
        End With
    Next r
    Next a
    Exit Sub
KakkoError:
    r = "'" & r
    Resume
End Sub

Sub 大括弧()
    Kakko Selection, "[", "]"
End Sub

Sub IncLine()
    Selection.Copy
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
    Selection.Offset(1, 0).Select
    Selection.ClearContents
End Sub

Sub MakeTextBox(Optional dummy As Integer = 0)
    Dim ttop As Single, tleft As Single, theight As Single, twidth As Single
    Dim nowShape As Shape
    Dim nowSelection
    If TypeName(Selection) = "ChartArea" Then
        Set nowSelection = Selection.Parent.Parent.ShapeRange
    Else
        Set nowSelection = Selection
    End If
    With nowSelection
        ttop = .Top
        tleft = .Left
        theight = .Height
        twidth = .Width
    End With
    Set nowShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, tleft, ttop, twidth, theight)
    With nowShape
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        .Select
        With .TextFrame
            .MarginLeft = 0#
            .MarginRight = 0#
            .MarginTop = 0#
            .MarginBottom = 0#
            .Characters.Text = ""
        End With
    End With
End Sub

Sub ShapesSelectAll(Optional dummy As Integer = 0)
    ActiveSheet.Shapes.SelectAll
End Sub

'Table：チェックする表を指定します。(データ部分のみを指定しますが、通常、タイトル行はデータと重複することはないと思いますので、含まれてもかまいません。)
'ColumnNo：検査する項目の番号(表内での列の番号です。)
'Order:重複行のうちxlAscendingは一番最初の行を残し、xlDesendingは一番最後の行を残します。
Function TrimTable(Optional ByVal Table As Range = Nothing, Optional ByVal ColumnNo As Long = 1, Optional Order As XlSortOrder = xlAscending) As Range
    Dim WorkRange As Range
    Dim Start As Long, Max As Long, l As Long
    Dim NowString As String
    If Table Is Nothing Then
        Set Table = Selection.CurrentRegion
        ColumnNo = ActiveCell.Column - Table.Column + 2
    Else
        ColumnNo = ColumnNo + 1
    End If
    Max = Table.Rows.Count
    If Max > 1 Then
        Application.ScreenUpdating = False
        With Table
            .Cells(1).EntireColumn.Insert xlShiftToRight
            Set WorkRange = .Offset(0, -1).Resize(ColumnSize:=.Columns.Count + 1)
        End With
        With WorkRange
            .Cells(1) = 1
            .Cells(1).AutoFill .Columns(1), xlFillSeries
            .Sort Key1:=.Cells(1, ColumnNo), Order1:=xlAscending, Key2:=.Cells(1), Order2:=Order, Header:=xlNo, OrderCustom:=1, MatchCase:=True, Orientation:=xlSortColumns
'TrimPartStart
            NowString = .Cells(1, ColumnNo).Text
            Start = 2: l = 2
            Do
                If .Cells(l, ColumnNo).Text <> NowString Then
                    If Start <> l Then
                        Range(.Rows(l), .Rows(Max)).Copy .Cells(Start, 1)
                        Range(.Rows(Max - l + Start + 1), .Rows(Max)).ClearContents
                        Max = Max - l + Start
                        l = Start
                    End If
                    Start = l + 1
                    NowString = .Cells(l, ColumnNo).Text
                End If
                l = l + 1
            Loop While l <= Max
            If Start <> Max + 1 Then
                Range(.Rows(Start), .Rows(Max)).ClearContents
                Max = Max - Start + 1
            End If
'TrimPartEnd
            .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=True, Orientation:=xlSortColumns
            .Cells(1).EntireColumn.Delete xlShiftToLeft
        End With
        Application.ScreenUpdating = True
    End If
    Set TrimTable = Range(Table.Rows(1), Table.Rows(Max))
End Function

Sub TrimTable2(Optional Target As Range = Nothing)
    Dim temp As Range
    If Target Is Nothing Then Set Target = Selection.CurrentRegion
    With Target
        Application.ScreenUpdating = False
        Set temp = ActiveWorkbook.Worksheets.Add.Cells(1)
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=temp, Unique:=True
        .Clear
        temp.CurrentRegion.Copy .Cells(1)
        Application.DisplayAlerts = False
        temp.Worksheet.Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = False
    End With
End Sub

'   関数名：SaveCopy
'   引数：  Path    String  (Optional)
'   説明：  現在使用しているファイルのバックアップファイルを作成します。
'       引数Pathで保存するフォルダを指定します。
'       (フォルダが存在しない場合はエラーとなります。)
'       省略した場合は元のファイルと同じフォルダに保存します。
'
'       バックアップファイルの名前は拡張子".xls"の前に".bak"をつけた
'       名前になります(それぞれ、定数XLS、DefaultBAKで定義しています)。
'       ただし、フォルダを指定した場合は".bak"は付きません。
'       また、一時ファイル等で拡張子".xls"が無い場合は自動で付加します。
'
'       もし、その名前が既に使用されていた場合は、".bak"に2から順に
'       数字をつけたファイル名を検索し、存在しないファイル名を探して
'       保存します(フォルダを指定した場合も同様に".bak"がつきます。
'       StartNumberに開始番号を定義しています。)
'
Sub SaveCopy(Optional Path As String = "")
    Const XLS As String = ".xls", DefaultBAK As String = ".bak"
    Const StartNumber As Integer = 2
    Dim fs As Object
    Dim NewFileName As String, NowPath As String, NowName As String
    Dim BAK As String
    Dim i As Integer
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Path = "" Then
        NowPath = ActiveWorkbook.Path: BAK = DefaultBAK
    Else
        NowPath = Path: BAK = ""
    End If
    NowName = ActiveWorkbook.Name
    If InStr(1, NowName, XLS, vbTextCompare) = 0 Then
        NowName = NowName & XLS
    End If
    NewFileName = Replace(NowName, XLS, BAK & XLS)
    i = StartNumber
    BAK = DefaultBAK
    Do While fs.FileExists(fs.BuildPath(NowPath, NewFileName))
        NewFileName = Replace(NowName, XLS, BAK & i & XLS)
        i = i + 1
    Loop
    On Error Resume Next
    ActiveWorkbook.SaveCopyAs Filename:=fs.BuildPath(NowPath, NewFileName)
    If Err.Number <> 0 Then MsgBox "書き込みに失敗しました。"
    Err.Clear
    On Error GoTo 0
End Sub

Private Function SheetLock(Sheet As Worksheet, Optional Switch As VBA.VbTriState = vbUseDefault, Optional PassWord As String = "") As Boolean
    On Error Resume Next
    Static DefaultProtect As Boolean
    Err.Clear
    Select Case Switch
    Case vbTrue
        If DefaultProtect = True Then
            Sheet.Protect PassWord:=PassWord
        End If
        SheetLock = True
    Case vbFalse
        DefaultProtect = Sheet.ProtectContents
        If DefaultProtect = True Then Sheet.Unprotect PassWord
        If Err.Number <> 0 Then
            SheetLock = False
        Else
            SheetLock = True
        End If
    Case Else
        SheetLock = DefaultProtect
    End Select
    On Error GoTo 0
End Function

Sub test()
    If SheetLock(ActiveSheet, vbFalse) = True Then
        Cells(1, 1) = 1
        Cells(1, 2) = Cells(1, 1) + Cells(1, 2)
        SheetLock ActiveSheet, vbTrue
    Else
        MsgBox "パスワードが解除できません。"
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    With Target.Cells(1)
        If .Locked = True And _
        .Worksheet.ProtectContents = True And _
        Application.MoveAfterReturn = True Then
            Select Case Application.MoveAfterReturnDirection
            Case xlToRight: .Offset(0, -1).Next.Select
            Case xlToLeft:  .Offset(0, 1).Next.Select
            Case xlUp:      .Offset(1, 0).Next.Select
            Case xlDown:    .Offset(-1, 0).Next.Select
            End Select
        End If
    End With
    Application.EnableEvents = True
End Sub

Sub SelectedAutoFit()
    Dim SA As Range
    For Each SA In Selection.Areas
        With SA
            .Columns.AutoFit
            .Rows.AutoFit
        End With
    Next SA
End Sub

Sub CellSizePaste()
    On Error Resume Next
    Dim nowCells As Range
    Dim nowShapeRange As ShapeRange
    Set nowCells = Selection
    ActiveSheet.Paste
    If TypeName(Selection) = "ChartArea" Then
        Set nowShapeRange = Selection.Parent.Parent.ShapeRange
    Else
        Set nowShapeRange = Selection.ShapeRange
    End If
    With nowShapeRange
        .LockAspectRatio = msoFalse
        .Height = nowCells.Height
        .Width = nowCells.Width
        .Top = nowCells.Top
        .Left = nowCells.Left
    End With
End Sub

Sub CellSizePaste2()
    On Error Resume Next
    Dim nowCells As Range
    Dim nowShapeRange As ShapeRange
    Dim mag As Double
    Set nowCells = Selection
    ActiveSheet.Paste
    If TypeName(Selection) = "ChartArea" Then
        Set nowShapeRange = Selection.Parent.Parent.ShapeRange
    Else
        Set nowShapeRange = Selection.ShapeRange
    End If
    With nowShapeRange
        mag = Application.WorksheetFunction.Min(CDbl(nowCells.Height) / .Height, CDbl(nowCells.Width) / .Width)
        .ScaleHeight mag, False
        .ScaleWidth mag, False
        .Top = nowCells.Top + (nowCells.Height - .Height) / 2
        .Left = nowCells.Left + (nowCells.Width - .Width) / 2
    End With
End Sub

Sub AbsoluteToRelative()
    Dim a As Range, r As Range
    If TypeName(Selection) = "Range" Then
        For Each a In Selection.Areas
        For Each r In a.Cells
            If r.HasFormula Then
                r.FormulaLocal = Replace(r.FormulaLocal, "$", "")
            End If
        Next r
        Next a
    Else
        MsgBox "セルを選択してから実行してください。", vbOKOnly, "絶対座標の相対座標への変換"
    End If
End Sub

Sub getNumber()
    Dim r As Range, a As Range
    Dim i As Integer, j As Integer
    Dim txt As String
    If TypeName(Selection) <> "Range" Then Exit Sub
    For Each a In Selection.Areas
    For Each r In a.Cells
        txt = r.Text
        For i = 1 To Len(txt)
            If IsNumeric(Mid(txt, i, 1)) Then
                txt = Right(txt, Len(txt) - i + 1)
                For j = Len(txt) To 1 Step -1
                    If IsNumeric(Left(txt, j)) Then
                        r = CDbl(Left(txt, j))
                        Exit For
                    End If
                Next j
                Exit For
            End If
        Next i
    Next r
    Next a
End Sub

Private Sub Workbook_Open()
    FloppyDataModule.init_FloppyData    '初期化の呼び出し
End Sub

Public X As New FloppyDataClass 'アプリケーションフック

Public Sub init_FloppyData()
    Set X.App = Excel.Application
    X.init
End Sub

Public WithEvents App As Application

Private Const FloppyLetter As String = "A:"
Private Const FullNameColumn As Integer = 1
Private Const NameColumn As Integer = 2
Private Const TempColumn As Integer = 3
Private index As Integer
Private ListSheet As Worksheet
Private fs As Object

Public Sub init()   '初期化
    index = 0
    Set ListSheet = ThisWorkbook.Worksheets(1)
    Set fs = CreateObject("Scripting.FileSystemObject")
End Sub

Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
    Dim fileindex As Integer
    If index = 0 Then   '一時保存ファイルが存在しない場合
        Cancel = False  'ファイルを閉じる。
        Exit Sub        '処理を終了する。
    End If
    
    On Error Resume Next
    Err.Clear
    '一時保存ファイルと一致するかどうか確認。
    fileindex = Application.WorksheetFunction.Match(Wb.Name, _
        Range(ListSheet.Cells(1, NameColumn), ListSheet.Cells(index, NameColumn)), 0)
    If Err.Number <> 0 Then '一致しない場合
        Cancel = False      'ファイルを閉じる。
        Exit Sub            '処理を終了する。
    End If
    On Error GoTo 0
    
    '一時保存ファイルを元のファイルに上書き
    '一時保存ファイルからリネームして編集した場合、
    'リネーム以前のファイルの編集が反映される。
    On Error Resume Next
    fs.DeleteFile ListSheet.Cells(fileindex, FullNameColumn), True
    On Error GoTo 0
    Wb.SaveAs ListSheet.Cells(fileindex, FullNameColumn)
    
    '一時保存ファイルを削除
'    On Error Resume Next
'    fs.DeleteFile ListSheet.Cells(fileindex, TempColumn), True
'    On Error GoTo 0
    
    'リストからファイル名等を削除
    ListSheet.Cells(fileindex, FullNameColumn) = ""
    ListSheet.Cells(fileindex, NameColumn) = ""
    ListSheet.Cells(fileindex, TempColumn) = ""
End Sub

Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
    If (Left(Wb.Path, 2) = FloppyLetter) Then   'フロッピーであることの確認
        'indexを1増加し、リストにファイル名等を入力
        index = index + 1
        ListSheet.Cells(index, FullNameColumn) = Wb.FullName
        ListSheet.Cells(index, NameColumn) = Wb.Name
        ListSheet.Cells(index, TempColumn) = fs.getSpecialFolder(2) & "\" & Wb.Name
        '一時保存ファイルを作成し、そのファイルを編集するようにする。
        '一時保存ファイルと同名のファイルがある場合、削除する。
        On Error Resume Next
        fs.DeleteFile ListSheet.Cells(index, TempColumn), True
        On Error GoTo 0
        Wb.SaveAs ListSheet.Cells(index, TempColumn)
    End If
End Sub

Public WithEvents App As Application

Set X.App = Excel.Application

Sub ConstValue(Optional dummy As Integer = 0)
    On Error Resume Next
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
End Sub

Sub WriteOutToCSV()
    Dim file As Variant
    Dim NewBook As Workbook
    Dim NowSheet As Worksheet
    Set NowSheet = ActiveSheet
    file = Application.GetSaveAsFilename(ActiveSheet.Name & ".csv", "カンマ区切り形式 (*.csv), *.csv")
    If file = False Then Exit Sub
    Set NewBook = Workbooks.Add
    NowSheet.Copy before:=NewBook.Worksheets(1)
    On Error Resume Next
    NewBook.Worksheets(1).SaveAs Filename:=file, FileFormat:=xlCSV
    On Error GoTo 0
    Application.DisplayAlerts = False
    NewBook.Close
    Application.DisplayAlerts = True
    NowSheet.Activate
End Sub