VBA 仕事効率 記事

【作業効率化】テストフェーズで便利なマクロ

赤枠追加

'全ての画像上(スクリーンショット等)に赤枠追加ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub キャプチャ上に赤枠追加()
    Dim shp As Shape
    Dim ran As Range
    Dim sp As Shape

'    選択シート内の図形全てを判定
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 13 Then
'           図形が配置されているセルの範囲を取得
            With ActiveSheet.Range(shp.TopLeftCell, shp.BottomRightCell)
                Set sp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, .left, .top, 100, 50)
            End With
            SetShapeStyleRedFrame sp
        End If
    Next

End Sub

'選択しているセルに赤枠追加ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 赤枠追加()
    Dim sp As Shape
    With ActiveCell
        Set sp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, .left, .top, 100, 50)
    End With
    
    SetShapeStyleRedFrame sp

End Sub


'赤枠のスタイル設定ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Private Sub SetShapeStyleRedFrame(ByRef sp As Shape)
    '枠線の設定
    With sp.Line
        .Weight = 4
        .ForeColor.RGB = RGB(255, 0, 0)
    End With
    
    '塗りつぶしの設定
    With sp.Fill
        .Visible = msoFalse
    End With

End Sub

青い吹き出し追加

'全ての画像に青吹き出し追加ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub AddBlueFukidashiToAllPictures()
    Dim shp As Shape
    Dim ran As Range
    Dim sp As Shape

'    選択シート内の図形全てを判定
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 13 Then
'           図形が配置されているセルの範囲を取得
            With ActiveSheet.Range(shp.TopLeftCell, shp.BottomRightCell)
                Set sp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, .left, .top, 150, 75)
            End With
            SetShapeStyleBlueFukidashi sp
        End If
    Next

End Sub

'選択しているセルに青吹き出し追加ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub AddBlueFukidashiToSelectCell()
    Dim sp As Shape
    With ActiveCell
        Set sp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, .left, .top, 150, 75)
    End With
    
    SetShapeStyleBlueFukidashi sp

End Sub


'青吹き出しのスタイル設定ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Private Sub SetShapeStyleBlueFukidashi(ByRef sp As Shape)
    '枠線の設定
    With sp.Line
        .Weight = 1
        .ForeColor.RGB = RGB(57, 153, 207)
    End With
    
    '塗りつぶしの設定
    With sp.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(57, 153, 207)
    End With

End Sub

シートの倍率設定

'全シートA1設定ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub setAllSheetsPointerA1()
    Dim WB As Workbook
    Set WB = ActiveWorkbook
  
    Dim WS As Worksheet
    
    'シートの数だけループ
    For Each WS In WB.Worksheets
        WS.Activate
        WS.Cells(1, 1).Select
    Next
  
    WB.Worksheets(1).Activate

    MsgBox "全シートA1選択完了しました。"
        
End Sub

'全シートA1設定ズーム倍率を現在開いているシートと統一ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub setAllSheetsPointerA1AndZoom()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim zoomSize As Integer
    
    Set WB = ActiveWorkbook
    zoomSize = ActiveWindow.zoom
    
    'シートの数だけループ&倍率設定
    For Each WS In WB.Worksheets
        WS.Activate
        WS.Cells(1, 1).Select
        ActiveWindow.zoom = zoomSize
    Next
  
    WB.Worksheets(1).Activate

    MsgBox "全シートA1選択倍率統一完了しました。"
        
End Sub

図形選択

'選択範囲の図形を全て選択ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub パーツ選択()
    Dim shp As Shape
    Dim ran As Range
    Dim sel

    Set sel = Selection
'    選択シート内の図形全てを判定
    For Each shp In ActiveSheet.Shapes
 
'        図形が配置されているセルの範囲を取得
        Set ran = Range(shp.TopLeftCell, shp.BottomRightCell)
'        選択した範囲と図形が配置されている範囲が被っていれば選択
        If Not Application.Intersect(ran, sel) Is Nothing Then
            shp.Select Replace:=False
        End If
    Next

End Sub

'選択範囲の画像以外の図形を全て選択ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 画像以外パーツ選択()
    Dim shp As Shape
    Dim ran As Range
    Dim sel

    Set sel = Selection
'    選択シート内の図形全てを判定
    For Each shp In ActiveSheet.Shapes
 
'        図形が配置されているセルの範囲を取得
        Set ran = Range(shp.TopLeftCell, shp.BottomRightCell)
'        選択した範囲と図形が配置されている範囲が被っていれば選択
        If Not Application.Intersect(ran, sel) Is Nothing Then
            If Not shp.Type = 13 Then
                shp.Select Replace:=False
            End If
        End If
    Next

End Sub

差分チェック

'2か所選択した範囲の差分確認(DBのSELECT文チェック等)ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub 差分確認()
    Dim ranTop, ranBottom As Range
    Dim i As Integer
    
    '複数選択範囲をそれぞれ分割して保持
    Set ranTop = Selection.Areas(1)
    Set ranBottom = Selection.Areas(2)

    For i = 1 To ranTop.Count
'        差分があれば後に選択した範囲に色を付ける
        If ranTop(i) <> ranBottom(i) Then
            ranBottom(i).Interior.ColorIndex = 3
        End If
    Next

End Sub

ファイル操作系

'フォルダパスをセルに貼付→そのセルを選択→フォルダ名をその後に選択し作成ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub フォルダ作成()
    Dim pathName, folder As Range
    Dim i As Integer
    Dim topPath, folderName, fullPath As String
    
    Set pathName = Selection.Areas(1)
    Set folder = Selection.Areas(2)
    topPath = pathName(1).Value

    For i = 1 To folder.Count
        folderName = folder(i).Value
        fullPath = topPath & "\" & folderName
'        同名のフォルダが無ければ作成
        If Dir(fullPath, vbDirectory) = "" Then
            MkDir fullPath
        End If
    Next

End Sub

'フォルダパス選択し、ファイル名を一括取得ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ファイル名一括取得()
    Dim FSO, tempFile As Object
    Dim TARGET As Files
    Dim path As String
    Dim r, c As Long
    Dim i As Integer
    
    Set FSO = New FileSystemObject
    path = ActiveCell.Value
    Set TARGET = FSO.GetFolder(path).Files
    r = ActiveCell.row + 2
    c = ActiveCell.Column
    
    Cells(r - 1, c).Value = "ファイル名一覧"
    
    For Each tempFile In TARGET
        Cells(r + i, c) = tempFile.Name
        i = i + 1
    Next
    
    MsgBox "ファイル名の一括取得が完了しました。"

End Sub

'フォルダパス→変更前ファイル名→変更後ファイル名の順に選択し、ファイル名を一括変更ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub ファイル名一括変更()
    Dim pathName, beforeName, afterName As String
    Dim path, beforeArea, afterArea As Range
    Dim i As Integer
    Dim beforeRow, beforeColumn, afterRow, afterColumn As Long
    
    Set path = Selection.Areas(1)
    Set beforeArea = Selection.Areas(2)
    Set afterArea = Selection.Areas(3)
    
    pathName = path(1).Value & "\"
    beforeRow = beforeArea(1).row
    beforeColumn = beforeArea(1).Column
    afterRow = afterArea(1).row
    afterColumn = afterArea(1).Column
    
    For i = 0 To beforeArea.Count - 1
        Name pathName & Cells(beforeRow + i, beforeColumn) As pathName & Cells(afterRow + i, afterColumn)
    Next
    
    MsgBox "ファイル名の変更が完了しました。"

End Sub

-VBA, 仕事効率, 記事
-, , ,

© 2024 ビギテック