セル
縦書き
縦書き
Sub セル_縦書き() '選択範囲を縦書きにする。 Dim w_range As Range Set w_range = Selection Range(Selection(1), Cells(Selection.Row, Selection.Column + Selection.Columns.Count - 1)).Select If Selection.Orientation = xlVertical Then With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlBottom .WrapText = False .Orientation = 90 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Else With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With End If If ActiveSheet.AutoFilterMode Then Selection.AutoFilter End If Rows(Selection.Row).AutoFilter Rows(Selection.Row + 1).Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True Cells.WrapText = False Cells.VerticalAlignment = xlTop Cells.Columns.AutoFit w_range.Select End Sub
書式_日付
書式_日付
Sub セル_書式_日付() 'セル_書式_日付 Macro Application.CutCopyMode = False If Selection(1).NumberFormatLocal = "yyyy/mm/dd;@" Then Selection.NumberFormatLocal = "yyyy/mm/dd hh:mm:ss;@" Else Selection.NumberFormatLocal = "yyyy/mm/dd;@" End If Selection.EntireColumn.AutoFit End Sub
内容結合
内容結合
Sub セル_内容結合()
'アクティブセルに内容を結合して編集する。
Dim w_range As Range Dim w_str As String For Each w_range In Selection w_str = w_str & w_range.Value Next w_range ActiveCell.Value = w_str Selection.Offset(1, 0).Select
End Sub
'アクティブセルに内容を結合して編集する。
Dim w_range As Range Dim w_str As String For Each w_range In Selection w_str = w_str & w_range.Value Next w_range ActiveCell.Value = w_str Selection.Offset(1, 0).Select
End Sub
内容分割
内容分割
Sub セル_内容分割()
'セルのコロン以降を抜き出しする。
Dim w_col As Integer w_col = InStr(1, ActiveCell, ":") If w_col < 1 Then w_col = InStr(1, ActiveCell, ":") End If If w_col > 0 Then ActiveCell.Offset(0, 1).NumberFormatLocal = "@" ActiveCell.Offset(0, 1).Value = Mid(ActiveCell, w_col + 1, 99) ActiveCell.Value = Left(ActiveCell, w_col) End If ActiveCell.Offset(1, 0).Activate
End Sub
'セルのコロン以降を抜き出しする。
Dim w_col As Integer w_col = InStr(1, ActiveCell, ":") If w_col < 1 Then w_col = InStr(1, ActiveCell, ":") End If If w_col > 0 Then ActiveCell.Offset(0, 1).NumberFormatLocal = "@" ActiveCell.Offset(0, 1).Value = Mid(ActiveCell, w_col + 1, 99) ActiveCell.Value = Left(ActiveCell, w_col) End If ActiveCell.Offset(1, 0).Activate
End Sub
情報
情報
Sub セル_情報()
Dim w_str As String Dim w_one As String Dim i As Integer w_str = "行番号:" & Selection(1).Row w_str = w_str & vbCrLf w_str = w_str & "列番号:" & Selection(1).Column w_str = w_str & vbCrLf w_str = w_str & "塗りつぶし色:" & Selection(1).Interior.ColorIndex w_str = w_str & vbCrLf w_str = w_str & "フォント色:" & Selection(1).Font.ColorIndex MsgBox w_str
End Sub
Dim w_str As String Dim w_one As String Dim i As Integer w_str = "行番号:" & Selection(1).Row w_str = w_str & vbCrLf w_str = w_str & "列番号:" & Selection(1).Column w_str = w_str & vbCrLf w_str = w_str & "塗りつぶし色:" & Selection(1).Interior.ColorIndex w_str = w_str & vbCrLf w_str = w_str & "フォント色:" & Selection(1).Font.ColorIndex MsgBox w_str
End Sub
塗りつぶし_色
塗りつぶし_色
Sub セル_塗りつぶし_色() 'セルの塗りつぶしの色を自動変換 If Selection(1).Interior.Color = 65535 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 49407 '橙 .TintAndShade = 0 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.Color = 49407 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 5296274 '緑 .TintAndShade = 0 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.Color = 5296274 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 '青 .TintAndShade = 0 .PatternTintAndShade = 0 End With Else With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 '黄 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If End Sub
フォント色
フォント色
Sub セル_フォント色()
Dim w_str As String Dim w_one As String Dim i As Integer w_str = "フォント色:" & Selection(1).Font.Color w_str = w_str & vbCrLf w_str = w_str & "先頭の空白数:" & CStr(Len(Selection) - Len(Trim(Selection))) w_str = w_str & vbCrLf For i = 1 To Len(Selection(1).Text) w_str = w_str & Mid(Selection(1).Text, i, 1) & ":" & Asc(Mid(Selection(1).Text, i, 1)) & ":" & Chr(Asc(Mid(Selection(1).Text, i, 1))) w_str = w_str & vbCrLf Next i
MsgBox w_str
End Sub
Dim w_str As String Dim w_one As String Dim i As Integer w_str = "フォント色:" & Selection(1).Font.Color w_str = w_str & vbCrLf w_str = w_str & "先頭の空白数:" & CStr(Len(Selection) - Len(Trim(Selection))) w_str = w_str & vbCrLf For i = 1 To Len(Selection(1).Text) w_str = w_str & Mid(Selection(1).Text, i, 1) & ":" & Asc(Mid(Selection(1).Text, i, 1)) & ":" & Chr(Asc(Mid(Selection(1).Text, i, 1))) w_str = w_str & vbCrLf Next i
MsgBox w_str
End Sub
SendKeys
SendKeys
Public Function SendKeys(InpKeys As String, Optional Wait As Boolean = False)
Static WSH As Object If WSH Is Nothing Then Set WSH = CreateObject("WScript.Shell") End If WSH.SendKeys InpKeys
End Function
Static WSH As Object If WSH Is Nothing Then Set WSH = CreateObject("WScript.Shell") End If WSH.SendKeys InpKeys
End Function
grepリンク作成
grepリンク作成
Sub セル_grepリンク作成()
'選択範囲を分解し、ハイパーリンクを張る。 Dim w_str As String Dim w_range As Range Dim w_col As Integer Dim w_col1 As Integer Dim w_col2 As Integer Dim w_col3 As Integer Dim w_col4 As Integer For Each w_range In Selection w_str = w_range.Value If Left(w_str, 1) = "■" Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 '青 .TintAndShade = 0 .PatternTintAndShade = 0 End With w_col = InStrRev(w_str, """") w_col1 = InStrRev(w_str, "\") w_col2 = InStrRev(w_str, "\", w_col1 - 1) w_col3 = InStrRev(w_str, "\", w_col2 - 1) w_col4 = InStrRev(w_str, "\", w_col3 - 1) w_range.Offset(0, 1).NumberFormatLocal = "@" w_range.Offset(0, 2).NumberFormatLocal = "@" w_range.Offset(0, 3).NumberFormatLocal = "@" w_range.Offset(0, 4).NumberFormatLocal = "@" w_range.Offset(0, 5).NumberFormatLocal = "@" w_range.Offset(0, 1).Value = Mid(w_str, w_col4 + 1, w_col3 - w_col4 - 1) w_range.Offset(0, 2).Value = Mid(w_str, w_col3 + 1, w_col2 - w_col3 - 1) w_range.Offset(0, 3).Value = Mid(w_str, w_col2 + 1, w_col1 - w_col2 - 1) w_range.Offset(0, 4).Value = Mid(w_str, w_col1 + 1, w_col - w_col1 - 1) w_range.Offset(0, 5).Value = Mid(w_str, 3, w_col - 3) w_range.Hyperlinks.Add Anchor:=w_range.Offset(0, 5), Address:=w_range.Offset(0, 5) End If Next w_range Range(Columns(Selection.Offset(0, 1).Column), Columns(Selection.Offset(0, 5).Column)).EntireColumn.AutoFit ActiveCell.Offset(1, 0).Select
End Sub
'選択範囲を分解し、ハイパーリンクを張る。 Dim w_str As String Dim w_range As Range Dim w_col As Integer Dim w_col1 As Integer Dim w_col2 As Integer Dim w_col3 As Integer Dim w_col4 As Integer For Each w_range In Selection w_str = w_range.Value If Left(w_str, 1) = "■" Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 '青 .TintAndShade = 0 .PatternTintAndShade = 0 End With w_col = InStrRev(w_str, """") w_col1 = InStrRev(w_str, "\") w_col2 = InStrRev(w_str, "\", w_col1 - 1) w_col3 = InStrRev(w_str, "\", w_col2 - 1) w_col4 = InStrRev(w_str, "\", w_col3 - 1) w_range.Offset(0, 1).NumberFormatLocal = "@" w_range.Offset(0, 2).NumberFormatLocal = "@" w_range.Offset(0, 3).NumberFormatLocal = "@" w_range.Offset(0, 4).NumberFormatLocal = "@" w_range.Offset(0, 5).NumberFormatLocal = "@" w_range.Offset(0, 1).Value = Mid(w_str, w_col4 + 1, w_col3 - w_col4 - 1) w_range.Offset(0, 2).Value = Mid(w_str, w_col3 + 1, w_col2 - w_col3 - 1) w_range.Offset(0, 3).Value = Mid(w_str, w_col2 + 1, w_col1 - w_col2 - 1) w_range.Offset(0, 4).Value = Mid(w_str, w_col1 + 1, w_col - w_col1 - 1) w_range.Offset(0, 5).Value = Mid(w_str, 3, w_col - 3) w_range.Hyperlinks.Add Anchor:=w_range.Offset(0, 5), Address:=w_range.Offset(0, 5) End If Next w_range Range(Columns(Selection.Offset(0, 1).Column), Columns(Selection.Offset(0, 5).Column)).EntireColumn.AutoFit ActiveCell.Offset(1, 0).Select
End Sub
フォント
フォント
Sub セル_フォント()
'フォントを自動変換する With Selection If .Font.name = "MS ゴシック" Then Selection.Font.name = "MS 明朝" ElseIf .Font.name = "MS 明朝" Then Selection.Font.name = "游ゴシック" ElseIf .Font.name = "游ゴシック" Then Selection.Font.name = "メイリオ" ElseIf .Font.name = "メイリオ" Then Selection.Font.name = "HGゴシックM" Else Selection.Font.name = "MS ゴシック" End If End With
End Sub
'フォントを自動変換する With Selection If .Font.name = "MS ゴシック" Then Selection.Font.name = "MS 明朝" ElseIf .Font.name = "MS 明朝" Then Selection.Font.name = "游ゴシック" ElseIf .Font.name = "游ゴシック" Then Selection.Font.name = "メイリオ" ElseIf .Font.name = "メイリオ" Then Selection.Font.name = "HGゴシックM" Else Selection.Font.name = "MS ゴシック" End If End With
End Sub
結合
結合
Sub セル_結合()
Dim w_range As Range Dim w_str As String w_str = "" For Each w_range In Selection If w_range.Value <> "" Then If w_str <> "" Then w_str = w_str & Chr(10) End If w_str = w_str & w_range.Value w_range.Value = "" End If Next w_range
Selection(1) = w_str Selection.Merge
End Sub
Dim w_range As Range Dim w_str As String w_str = "" For Each w_range In Selection If w_range.Value <> "" Then If w_str <> "" Then w_str = w_str & Chr(10) End If w_str = w_str & w_range.Value w_range.Value = "" End If Next w_range
Selection(1) = w_str Selection.Merge
End Sub
削除、挿入
削除、挿入
Sub セル_削除左()
'セルを削除して、左に詰める Selection.Delete Shift:=xlShiftToLeft End Sub
Sub セル_削除上() 'セルを削除して、上に詰める Selection.Delete Shift:=xlUp
End Sub
Sub セル_挿入下() 'セルを挿入して、下にずらす Application.CutCopyMode = False Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Sub セル_挿入右() 'セルを挿入して、右にずらす Application.CutCopyMode = False Selection.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
'セルを削除して、左に詰める Selection.Delete Shift:=xlShiftToLeft End Sub
Sub セル_削除上() 'セルを削除して、上に詰める Selection.Delete Shift:=xlUp
End Sub
Sub セル_挿入下() 'セルを挿入して、下にずらす Application.CutCopyMode = False Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Sub セル_挿入右() 'セルを挿入して、右にずらす Application.CutCopyMode = False Selection.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
比較
比較
Sub セル_比較()
If Selection(1) = Selection(2) Then MsgBox "同じ" Else MsgBox "違う" End If
End Sub
If Selection(1) = Selection(2) Then MsgBox "同じ" Else MsgBox "違う" End If
End Sub
表示形式
表示形式
Sub セル_表示形式() If Selection.NumberFormatLocal = "@" Then Selection.NumberFormatLocal = "G/標準" Else Selection.NumberFormatLocal = "@" End If
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then SendKeys ("{F2}") SendKeys ("{ENTER}") End If
End Sub
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then SendKeys ("{F2}") SendKeys ("{ENTER}") End If
End Sub
右空白削除
右空白削除
Sub セル_右空白削除()
'右の空白を削除する Dim w_range As Range For Each w_range In Selection w_range = RTrim(w_range) Next w_range
End Sub
'右の空白を削除する Dim w_range As Range For Each w_range In Selection w_range = RTrim(w_range) Next w_range
End Sub
罫線細中線
罫線細中線
Sub セル_罫線細中線() '罫線細中線を引く
With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlHairline End With
End Sub
With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlHairline End With
End Sub
連番
連番
Sub セル_連番()
'選択範囲で、空白以外のセルに連番を振る。 Dim w_range As Range Dim x As Integer x = 1 For Each w_range In Selection If w_range <> "" Then w_range = x x = x + 1 End If Next w_range
End Sub
'選択範囲で、空白以外のセルに連番を振る。 Dim w_range As Range Dim x As Integer x = 1 For Each w_range In Selection If w_range <> "" Then w_range = x x = x + 1 End If Next w_range
End Sub
値行列の入れ替え
値行列の入れ替え
Sub セル_値行列の入れ替え() 'セルの値を行列入れ替えて張り付ける On Error Resume Next Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True On Error GoTo 0
End Sub
End Sub
F2押下
F2押下
Sub セル_F2押下()
'選択範囲でF2を押下する。
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 c_end = .Column + .Columns.Count - 1 End With With Selection r_start = .Row If .Row + .Rows.Count - 1 < r_end Then r_end = .Row + .Rows.Count - 1 End If c_start = .Column If .Column + .Columns.Count - 1 < c_end Then c_end = .Column + .Columns.Count - 1 End If End With ' Application.ScreenUpdating = False With Selection For i = r_start To r_end For j = c_start To c_end s.Cells(i, j).Activate SendKeys "{F2}", True SendKeys "{ENTER}", True Next j Next i End With' Application.ScreenUpdating = True
End Sub
'選択範囲でF2を押下する。
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 c_end = .Column + .Columns.Count - 1 End With With Selection r_start = .Row If .Row + .Rows.Count - 1 < r_end Then r_end = .Row + .Rows.Count - 1 End If c_start = .Column If .Column + .Columns.Count - 1 < c_end Then c_end = .Column + .Columns.Count - 1 End If End With ' Application.ScreenUpdating = False With Selection For i = r_start To r_end For j = c_start To c_end s.Cells(i, j).Activate SendKeys "{F2}", True SendKeys "{ENTER}", True Next j Next i End With' Application.ScreenUpdating = True
End Sub
使用範囲へコピー
使用範囲へコピー
Sub セル_使用範囲へコピー() '選択範囲を使用範囲へコピーする。 Dim s As Worksheet Dim w_range As Range Dim w_range1 As Range Set w_range = Selection Set s = ActiveSheet With s.UsedRange Set w_range1 = s.Range(Selection(1), s.Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1)) End With w_range.Copy w_range1.Select ActiveSheet.Paste
End Sub
End Sub
上のセルを前に編集
上のセルを前に編集
Sub セル_上のセルを前に編集()
'上のセルを前に編集
Dim w_range As Range Dim w_str As String w_str = Selection(1).Offset(-1, 0).Value ' Selection.UnMerge' Selection.WrapText = False' Selection.Columns(1).Select Selection.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Application.ScreenUpdating = False For Each w_range In Selection.Cells If w_range.Value <> "" Then w_range.Value = w_str & w_range.Value End If
Next w_range Application.ScreenUpdating = True
End Sub
'上のセルを前に編集
Dim w_range As Range Dim w_str As String w_str = Selection(1).Offset(-1, 0).Value ' Selection.UnMerge' Selection.WrapText = False' Selection.Columns(1).Select Selection.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Application.ScreenUpdating = False For Each w_range In Selection.Cells If w_range.Value <> "" Then w_range.Value = w_str & w_range.Value End If
Next w_range Application.ScreenUpdating = True
End Sub
書式文字列
書式文字列
Sub セル_書式文字列() '選択範囲の書式を文字列に設定する。 Selection.NumberFormatLocal = "@"
End Sub
End Sub
極太外枠
極太外枠
Sub セル_極太外枠()
'選択範囲に極太外枠を引く With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With End Sub
'選択範囲に極太外枠を引く With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With End Sub
かぎかっこ
かぎかっこ
Sub セル_かぎかっこ()
'選択セルを、鍵かっこで囲む。
If Selection.Value <> "" Then Selection.Value = "「" & Selection.Value & "」" End If Selection.Offset(1, 0).Select
End Sub
'選択セルを、鍵かっこで囲む。
If Selection.Value <> "" Then Selection.Value = "「" & Selection.Value & "」" End If Selection.Offset(1, 0).Select
End Sub
ハイパーリンク
ハイパーリンク
Sub セル_ハイパーリンク()
If ActiveCell <> "" Then ActiveCell.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Selection.Text, TextToDisplay:=Selection.Text End If ActiveCell.Offset(1, 0).Select
End Sub
If ActiveCell <> "" Then ActiveCell.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Selection.Text, TextToDisplay:=Selection.Text End If ActiveCell.Offset(1, 0).Select
End Sub