セル

Private Sub Worksheet_Change(ByVal Target As Range)
'◆ハイパーリンク削除 Dim w_range As Range Select Case Target.Address Case Range("_樹脂加工報告書").Address, Range("_TMC報告書").Address Set w_range = Target.MergeArea Target.Hyperlinks.Delete
With w_range .Merge With .Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Font .Name = "Meiryo UI" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With End With End Select End Sub

結合式

Sub セル_結合式()
    '選択範囲のセルの結合式を作成する。
    Dim w_str As String    Dim w_cell As Range
    w_str = "="    For Each w_cell In Selection        If w_cell.Text = Selection(Selection.Count).Text Then            w_cell = w_str        ElseIf w_cell.Text = Selection(Selection.Count - 1).Text Then            w_str = w_str & w_cell.Address(RowAbsolute:=False, ColumnAbsolute:=False)        Else            w_str = w_str & w_cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & "&"        End If    Next w_cell
End Sub

縦書き

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

内容分割

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

フォント色

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

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

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

フォント

Sub セル_フォント()
'フォントを自動変換する With Selection If .Font.name = "ＭＳゴシック" Then Selection.Font.name = "ＭＳ明朝" ElseIf .Font.name = "ＭＳ明朝" Then Selection.Font.name = "游ゴシック" ElseIf .Font.name = "游ゴシック" Then Selection.Font.name = "メイリオ" ElseIf .Font.name = "メイリオ" Then Selection.Font.name = "HGｺﾞｼｯｸM" Else Selection.Font.name = "ＭＳゴシック" 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

削除、挿入

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

表示形式

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

右空白削除

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

連番

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

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

使用範囲へコピー

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

上のセルを前に編集

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

極太外枠

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

ハイパーリンク

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