赤枠追加
'全ての画像上(スクリーンショット等)に赤枠追加ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
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