Skip to content

Instantly share code, notes, and snippets.

@Neos21

Neos21/Personal.bas

Created Mar 29, 2017
Embed
What would you like to do?
個人用マクロまとめ
Option Explicit
' 赤枠のオブジェクトを挿入する
' 普段は Ctrl + Shift + S を設定している
Sub 赤枠()
' Left, Top, Width, Height
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, ActiveCell.Left, ActiveCell.Top, 144, 45).Select
With Selection.ShapeRange
.Fill.Visible = msoFalse
With .Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
With .TextFrame2
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.VerticalAnchor = msoAnchorMiddle
With .TextRange.Font
.NameComplexScript = "メイリオ"
.NameFarEast = "メイリオ"
.Name = "メイリオ"
.Size = 9
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Solid
End With
End With
End With
End With
End Sub
' 赤枠のフキダシを挿入する
' 普段は Ctrl + Shift + D を設定している
Sub 赤フキダシ()
' Left, Top, Width, Height
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangularCallout, ActiveCell.Left, ActiveCell.Top, 144, 45).Select
With Selection.ShapeRange
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.Transparency = 0
.Solid
End With
With .Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
With .TextFrame2.TextRange.Font
.NameComplexScript = "メイリオ"
.NameFarEast = "メイリオ"
.Name = "メイリオ"
.Size = 9
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Solid
End With
End With
End With
End Sub
' セルを縦方向に結合する
' クイックアクセスツールバーに置いて使っている
' http://neos21.hatenablog.com/entry/2017/03/03/002937
' https://memo.xight.org/2010-02-24-1
' http://qiita.com/AfricaUmare/items/2602cd80290cd5a41eaf
Sub 縦方向に結合()
On Error Resume Next
' 選択範囲がセルでない時は動作させない
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
With Selection
If .Rows.Count > 1 Then
Dim i As Integer
For i = 0 To .Columns.Count - 1
range(Cells(.Row, .Column + i), Cells(.Row + .Rows.Count - 1, .Column + i)).Merge
Next i
End If
End With
On Error GoTo 0
End Sub
' 空行が混じっても崩れない連番を振る
' http://neos21.hatenablog.com/entry/2016/01/26/015250
Sub 縦に連番()
Selection.Formula = "=IFERROR(MAX(INDIRECT(ADDRESS(1, COLUMN())):INDIRECT(ADDRESS(ROW() - 1, COLUMN()))) + 1, 1)"
End Sub
' 空行が混じっても崩れない連番を振る
' http://neos21.hatenablog.com/entry/2016/01/26/015250
Sub 横に連番()
Selection.Formula = "=IFERROR(MAX(INDIRECT(ADDRESS(ROW(), 1)):INDIRECT(ADDRESS(ROW(), COLUMN() - 1))) + 1, 1)"
End Sub
' よく使う日付の書式
Sub 日付書式()
With Selection
.NumberFormatLocal = "yyyy-mm-dd"
.HorizontalAlignment = xlCenter
End With
End Sub
' よく使う日付の書式
Sub 日付書式曜日入り()
With Selection
.NumberFormatLocal = "yyyy-mm-dd (aaa)"
.HorizontalAlignment = xlCenter
End With
End Sub
' Excel2016 から「コメント」オブジェクトのフォント設定ができなくなったようなのでマクロで修正する
' http://www.moug.net/tech/exvba/0050137.html
' http://www.relief.jp/itnote/archives/018465.php
Sub 選択セルのコメント書式を変更()
If TypeName(ActiveCell.Comment) = "Nothing" Then
MsgBox "コメントなし"
Exit Sub
End If
With ActiveCell.Comment.Shape.TextFrame.Characters.Font
.Name = "メイリオ"
.Size = 9
.Bold = False
End With
End Sub
' Excel2016 から「コメント」オブジェクトのフォント設定ができなくなったようなのでマクロで修正する
' http://www.relief.jp/itnote/archives/excel-vba-for-each-loop-cells-having-comment.php
Sub シート内の全コメント書式を変更()
On Error GoTo COMMENT_NOT_FOUND
Dim range As range
For Each range In ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
With range.Comment.Shape.TextFrame.Characters.Font
.Name = "メイリオ"
.Size = 9
.Bold = False
End With
Next range
Exit Sub
COMMENT_NOT_FOUND:
Err.Clear
MsgBox "コメントなし"
End Sub
@Neos21

This comment has been minimized.

Copy link
Owner Author

@Neos21 Neos21 commented May 13, 2019

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment