グループごとの順位「SUMPRODUCT関数」
都道府県別に何月の売上金額が多かったのか順位をつける。
（例）北海道 1位：6月 2位：4月 3位：5月
↓
SUMPRODUCT関数
対応する配列の合計を返す関数。
配列を乗算し、最後に1を足すことでグループ内での順位を出している。
↓D1セルには2が表示するようにしている。（北海道の中で507が2番目に大きいから）
D2セルに「=SUMPRODUCT*1+1」と入力している。
SUMPRODUCT関数の「引数1」に「+1」をすることで順位2を求めている。
配列について
SUMPRODUCT(($B$2:$B$10=B2)*($C$2:$C$10>C2))の結果は、
{0;0;0;0;0;0;0;1;0}となっている。このままだと1が表示されるだけ。
($B$2:$B$10=B2)について
$B$2:$B$10の範囲とB2が一致しているかどうかを判別している。
一致していればTRUE=1、不一致の場合はFALSE=0となる。
{1;0;0;1;0;0;0;1;0}となる。
($C$2:$C$10>C2)について
$C$2:$C$10の範囲でC2よりも大きい数値があるかどうか判別している。
大きければTRUE=1、小さければFALSE=0となる。
{0;0;1;0;0;1;1;1;1}となる。
↓C2(507)より大きいのは769,677,533,666,537の5つ。
SUMPRODUCT(($B$2:$B$10=B2)*($C$2:$C$10>C2))
→SUMPRODUCT({1;0;0;1;0;0;0;1;0}*{0;0;1;0;0;1;1;1;1})
→1
グループ北海道の中で507より大きい数字は666の1つのみ。
つまり507は2番目に大きい数字ということになる。
順位をつける為最後に+1をしている。
一覧表作成
それぞれ順位をつけたものを表に反映させる。
それぞれキーを作成し、INDEXMATCHで表示させる。
*1:$B$2:$B$10=B2)*($C$2:$C$10>C2
VBA100本ノック14本目：社外秘シート削除
出題内容
客先へ送付するブックを作成します。
シート名に「社外秘」の文字が含まれるシートを削除してください。
他のシートは計算式を消して値だけにしてください。
※シート間参照の数式あり。
※条件付き書式・入力規則は未使用。
※対象はアクティブブックで構いません。
自分の解答
Sub wrk()
Dim i As Long
Dim c As Long
Application.DisplayAlerts = False
For i = 1 To Sheets.Count
If InStr(Sheets(i).Name, "社外秘") <> 0 Then
c = i
Else
Sheets(i).Cells.Copy
Sheets(i).Range("A1").PasteSpecial Paste:=xlPasteValues
End If
Next iOn Error Resume Next
Sheets(c).Delete
Application.DisplayAlerts = TrueEnd Sub
その他
非表示シートがあるかも
保護がかかっていて削除できないかも
VBA100本ノック13本目：文字列の部分フォント
出題内容
選択セル（Selection:複数範囲あり）の文字列に「注意」という文字があった場合は、その「注意」の文字だけを"赤の太字"に設定してください。
セル以外（図形等）が選択されている場合は何もせずに正常終了するようにしてください。
自分の解答
Sub vba13()
Dim 検索キーワード As String
Dim 発見位置 As Long
Dim 文字数 As Long
Dim i As Long
検索キーワード = "注意"
文字数 = Len(検索キーワード)
For i = 1 To Selection.Count
発見位置 = InStr(Selection.Item(i), 検索キーワード)
If 発見位置 <> 0 Then
With Selection.Item(i).Characters(Start:=発見位置, Length:=文字数)
.Font.ColorIndex = 3
.Font.Bold = True
End With
Else
End If
NextEnd Sub
2つ目の"注意"に対して処理できていない。
図形が選択されている時の対応ができていない。
修正
Instrで文字列検索する際に、開始位置をずらすことで2つ目の"注意”に対応できるように修正。
"注意"という文字列が存在しない場合は0になる。結果が0になった場合はループを抜ける。
Sub vba13()
Dim 検索キーワード As String
Dim 発見位置 As Long
Dim 文字数 As Long
Dim i As Long
Dim ix As Long
検索キーワード = "注意"
文字数 = Len(検索キーワード)
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
For i = 1 To Selection.Count
ix = 1
Do
発見位置 = InStr(ix, Selection.Item(i), 検索キーワード)
If 発見位置 = 0 Then
Exit Do
Else
With Selection.Item(i).Characters(Start:=発見位置, Length:=文字数)
.Font.ColorIndex = 3
.Font.Bold = True
End With
ix = 発見位置 + 文字数
End If
Loop
NextEnd Sub
VBA100本ノック12本目：セル結合を解除
出題内容
#VBA100本ノック 12本目
A1から始まる表範囲のC列に金額が入っています。
しかし、ところどころに結合されたセルがあります。
セル結合を解除し、入っている金額を整数で均等に割り振ってください。（2枚目画像）
端数処理方法は任意とします。
※結合セルには正の整数しか入っていません。
自分の解答
Sub vba12()
Dim rng As Range
Dim val As Variant
For Each rng In Range("C1:C" & Cells(Rows.Count, 3).End(xlUp).Row)
If rng.MergeCells Then
val = rng.Value
With rng.MergeArea
.UnMerge
.Value = val / .Count
End With
End If
Next rng
End Sub
.Value = val / .Count としている為、割り算の結果がそのまま各セルに入力される。
小数点ではなく整数で入力したい。
修正
Sub vba12()
Dim rng As Range
Dim val As Variant
Dim i As Long
For Each rng In Range("C1:C" & Cells(Rows.Count, 3).End(xlUp).Row)
If rng.MergeCells Then
val = rng.Value
With rng.MergeArea
.UnMerge
i = Int(val / .Count)
.Value = i
rng(1) = rng(1) + val - (i * .Count)
End With
End If
Next rng
End Sub
Intで切り捨てた後にあまりをrng(1)に足す。
余りが大きい場合はrng(1)のズレも大きくなってしまう。
VBA100本ノック11本目：セル結合の警告
出題内容
画像のようにシートにはところどころにセル結合があります。
これは放置しておく訳にはいきません。
セル結合されているセルには、メモ（旧コメント）で警告文を出しましょう。
※シートは任意、警告文はご随意に
自分の解答
Sub vba11()
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 3).MergeCells Then
Cells(i, 3).AddComment "結合されています"
End If
Next i
End Sub
3列目に対してのみ処理をかけている。
1、2列目のデータに結合されているセルがあってもコメントをつけることができない。
既にコメントされているセルに対してコメントをつけようとするとエラーになる。
修正
一度コメントを削除してから、全セルに対して処理をかけるコードに修正。
Sub VBA11()
Dim rng As Range
'コメント削除
Range("A1").CurrentRegion.ClearComments
'全セルを対象
For Each rng In Range("A1").CurrentRegion
If rng.MergeCells Then
rng.AddComment "セル結合されています"
End If
Next
End Sub
VBA100本ノック10本目：行の削除
出題内容
画像のように「受注」シートに今月の受注データがあります。
受注数が空欄かつ備考欄に「削除」または「不要」の文字が含まれている行を削除してください。
行の削除は行全体を削除してください。
サンプルでは5行目と10行目を削除
自分の解答
Sub vba10()
Sheets("受注").AutoFilterMode = False '①
With Sheets("受注").Range("A1")
.AutoFilter field:=3, Criteria1:=""
.AutoFilter field:=4, Criteria1:="*削除*", _
Operator:=xlOr, Criteria2:="*不要*"
.CurrentRegion.Offset(1, 0).EntireRow.Delete
.AutoFilter
End WithEnd Sub
修正箇所
①処理開始前にフィルターを解除しておくコードを追加。
Offset後に削除している為、一行下の空行も削除している。
問題がある場合はResizeを使うかIntersectで対応する。
