行
追加
追加
Sub 行_追加()
Dim w_range As Range
Set w_range = Selection
Selection.EntireRow.Insert Rows(Selection.Row).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With
With Selection.Font .ThemeColor = xlThemeColorLight1 '黒 .TintAndShade = 0 .size = 11 End With
w_range.Select
End Sub
Dim w_range As Range
Set w_range = Selection
Selection.EntireRow.Insert Rows(Selection.Row).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With
With Selection.Font .ThemeColor = xlThemeColorLight1 '黒 .TintAndShade = 0 .size = 11 End With
w_range.Select
End Sub
グループ化
グループ化
Sub 行_グループ化()
Dim r_end As Long Dim c_end As Long Dim w_active As Range Dim i As Integer Dim i1 As Integer Dim s As Worksheet Set s = ActiveSheet Set w_active = ActiveCell With s.UsedRange r_end = .Row + .Rows.Count - 1 c_end = .Column + .Columns.Count - 1 End With s.Cells.Select On Error Resume Next Selection.Rows.Ungroup Selection.Rows.Ungroup Selection.Rows.Ungroup On Error GoTo 0 For i = 3 To r_end If s.Cells(i, 1).Value <> "" And s.Cells(i, 1).Value = 2 And s.Cells(i + 1, 1).Value > 2 Then For i1 = i + 1 To r_end + 1 If s.Cells(i1, 1).Value = "" Or s.Cells(i1, 1).Value <= 2 Then Exit For End If Next i1 s.Range(s.Rows(i + 1), s.Rows(i1 - 1)).Select Selection.Rows.Group End If Next i w_active.Select End Sub
Dim r_end As Long Dim c_end As Long Dim w_active As Range Dim i As Integer Dim i1 As Integer Dim s As Worksheet Set s = ActiveSheet Set w_active = ActiveCell With s.UsedRange r_end = .Row + .Rows.Count - 1 c_end = .Column + .Columns.Count - 1 End With s.Cells.Select On Error Resume Next Selection.Rows.Ungroup Selection.Rows.Ungroup Selection.Rows.Ungroup On Error GoTo 0 For i = 3 To r_end If s.Cells(i, 1).Value <> "" And s.Cells(i, 1).Value = 2 And s.Cells(i + 1, 1).Value > 2 Then For i1 = i + 1 To r_end + 1 If s.Cells(i1, 1).Value = "" Or s.Cells(i1, 1).Value <= 2 Then Exit For End If Next i1 s.Range(s.Rows(i + 1), s.Rows(i1 - 1)).Select Selection.Rows.Group End If Next i w_active.Select End Sub
空白行削除
空白行削除
Sub 行_空白行削除()
'セレクト列が空白の行を削除
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim r_select_start As Long Dim r_select_end As Long Dim c_select_start As Integer Dim c_select_end As Integer Dim i As Long
With Selection r_select_start = .Row r_select_end = .Row + .Rows.Count - 1 c_select_start = .Column c_select_start = .Column + .Columns.Count - 1 End With
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 If r_select_end < r_end Then r_end = r_select_end End If End With Application.StatusBar = False For i = r_end To r_select_start Step -1 If s.Cells(i, c_select_start).Value = "" Then s.Rows(i).Delete End If Next i Application.StatusBar = True End Sub
'セレクト列が空白の行を削除
Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim r_select_start As Long Dim r_select_end As Long Dim c_select_start As Integer Dim c_select_end As Integer Dim i As Long
With Selection r_select_start = .Row r_select_end = .Row + .Rows.Count - 1 c_select_start = .Column c_select_start = .Column + .Columns.Count - 1 End With
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 If r_select_end < r_end Then r_end = r_select_end End If End With Application.StatusBar = False For i = r_end To r_select_start Step -1 If s.Cells(i, c_select_start).Value = "" Then s.Rows(i).Delete End If Next i Application.StatusBar = True End Sub