2011年5月アーカイブ

ActiveWindow.FreezePanes = False 'ウィンドウ枠固定の解除
Columns("BR:BR").Select
Selection.Delete Shift:=xlToLeft
Columns("BI:BK").Select
Selection.Delete Shift:=xlToLeft
Columns("BG:BG").Select
Selection.Delete Shift:=xlToLeft
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft

Sub height_henkou()
Dim L As Integer
Dim C1 As Integer '確実に文字が入っている列を指定する1
Dim C2 As Integer '確実に文字が入っている列を指定する2
Dim loopflg As Boolean
C1 = 2
C2 = 3
L = 1 '初期値
loopflg = False
Do
L = L + 1
If IsEmpty(Cells(L, C1).Value) And IsEmpty(Cells(L, C2).Value) Then
loopflg = True
End If
Loop Until loopflg
Rows(2 & ":" & L).Select
Selection.RowHeight = 28
End Sub

一旦空いている列に赤という文字を挿入した後並べ替えて削除しています。
（そうしたほうが処理が早い）また空白セルがある間ループしているのですが
空白セルを2カ所指定しています。ただ行の終わりを調べる関数もあるのでそれでも良かったかも。

Sub lively_touroku()
Dim L As Integer
Dim C1 As Integer '確実に文字が入っている列を指定する1
Dim C2 As Integer '確実に文字が入っている列を指定する2
Dim loopflg As Boolean
C1 = 2
C2 = 3
ActiveWindow.FreezePanes = False 'ウィンドウ枠固定の解除
L = 1 '初期値
loopflg = False
Do
If Cells(L, 1).Interior.ColorIndex = 3 Then
Cells(L, 4).Value = "赤"
'Rows(L).Delete Shift:=xlUp
End If
L = L + 1
'MsgBox (Str(C1))
If IsEmpty(Cells(L, C1).Value) And IsEmpty(Cells(L, C2).Value) Then
loopflg = True
End If
Loop Until loopflg
'並べ替え
Cells.Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
'赤の行の範囲を得る
L = 1 '初期値
Do While Cells(L, 4).Value <> "" 'C列に何か入っている間繰り返す。
L = L + 1
Loop
Rows(2 & ":" & (L - 1)).Select
Selection.Delete Shift:=xlUp
End Sub