マクロサンプルの最近のブログ記事

A列とB列を比べて同じならC列に○を入れます。

Dim L As Integer
L = 1 '初期値
Do While Cells(L, 1).Value <> ""
If Cells(L, 1).Value <> Cells(L, 2).Value Then
Cells(L, 3).Value = "×"
Else
Cells(L, 3).Value = "○"
End If
L = L + 1
Loop

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

Sub 同じのに色()
    Dim N As Long
    Dim buf1, buf2 As String
    N = 2 '初期値
        Do While Cells(N, 1).Value <> ""
            buf1 = Cells(N - 1, 8)
            buf2 = Cells(N, 8)
            If buf2 = buf1 Then
                Cells(N - 1, 8).Interior.ColorIndex = 36 '黄色
                Cells(N, 8).Interior.ColorIndex = 36 '黄色
            End If
            N = N + 1
        Loop
End Sub

Sub 同じのに印()
	Dim N, T As Integer
	Dim buf1, buf2, buf3 As String
		For N = 2 To 1000
			buf1 = Cells(N - 1, 3)
			buf2 = Cells(N, 3)
			If buf2 = buf1 Then
				Cells(N - 1, 1) = "■完全一致"
				Cells(N, 1) = "■完全一致"
			End If
		Next
End Sub

Sub 同じの外す()
	Dim N, T As Integer
	Dim buf1, buf2, buf3 As String
		For N = 2 To 1000
			buf1 = Left(Cells(N - 1, 2), 4)
			buf2 = Left(Cells(N, 2), 4)
			buf3 = Left(Cells(N + 1, 2), 4)
			If buf2 <> buf1 And buf2 <> buf3 Then
				Cells(N, 2) = "同じでない：" + Cells(N, 2)
			End If
		Next
End Sub

Sub setcolor()
    Dim L As Integer
    Dim goukei As Long
    L = 1 '初期値
    Do While Cells(L + 1, 1).Value <> ""'E列に何か入っている間繰り返す。
        If IsNumeric(Cells(L, 5)) Then'数値なら
            If Cells(L, 5) < 10 Then
                Cells(L, 5).Interior.ColorIndex = xlNone
            ElseIf 9 < Cells(L, 5) And Cells(L, 5) < 20 Then
                Cells(L, 5).Interior.ColorIndex = 36
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 19 < Cells(L, 5) And Cells(L, 5) < 30 Then
                Cells(L, 5).Interior.ColorIndex = 6
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 29 < Cells(L, 5) And Cells(L, 5) < 40 Then
                Cells(L, 5).Interior.ColorIndex = 44
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 39 < Cells(L, 5) And Cells(L, 5) < 100 Then
                Cells(L, 5).Interior.ColorIndex = 45
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            End If
        Else
                Cells(L, 5).Interior.ColorIndex = xlNone
        End If
        L = L + 1
    Loop
End Sub

Sub 合体FG()
	Dim N As Integer
	Dim buf As String
	For N = 1 To 525
		If Cells(N, 6) = "" Then
			Cells(N, 6) = Cells(N, 7)
		ElseIf Cells(N, 7) = "" Then
			Cells(N, 6) = Cells(N, 6)
		Else
			Cells(N, 6) = Cells(N, 6) + "
" + Cells(N, 7)
		End If
	Next
End Sub

Sub 特定のセルに文字を追加()
	Dim N, T As Integer
	Dim buf, Head As String
	T = 51
	For T = 1 To 5
		If T = 1 Then
			Head = "大:"
		ElseIf T = 2 Then
			Head = "小:"
		ElseIf T = 3 Then
			Head = "サブ1:"
		ElseIf T = 4 Then
			Head = "サブ2:"
		ElseIf T = 5 Then
			Head = "サブ3:"
		End If
		For N = 2 To 525
			'MsgBox (Cells(N, T))
			If Str(Cells(N, T)) = "0" Then
				'MsgBox (Str(N) + "/" + Str(T))
			ElseIf Cells(N, T) = 0 Then
			
			Else
				Cells(N, T) = Head + Str(Cells(N, T))
			End If
		Next
	Next

End Sub