PCメモ

Excelを中心とした業務改善の記録

グループごとの順位「SUMPRODUCT関数」

 

 

都道府県別に何月の売上金額が多かったのか順位をつける。

(例)北海道 1位:6月 2位:4月 3位:5月

 

f:id:abv72:20220125145441p:plain

f:id:abv72:20220125154012p:plain

 

SUMPRODUCT関数

対応する配列の合計を返す関数。
配列を乗算し、最後に1を足すことでグループ内での順位を出している。

Microsoft「SUMPRODUCT関数について」

↓D1セルには2が表示するようにしている。(北海道の中で507が2番目に大きいから)

f:id:abv72:20220125145956p:plain

 

D2セルに「=SUMPRODUCT*1+1」と入力している。

SUMPRODUCT関数の「引数1」に「+1」をすることで順位2を求めている。

f:id:abv72:20220125151008p:plain


配列について

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}となる。

f:id:abv72:20220125151828p:plain

 

($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つ。

f:id:abv72:20220125152126p:plain

 

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をしている。

 

一覧表作成

それぞれ順位をつけたものを表に反映させる。

f:id:abv72:20220125153341p:plain

それぞれキーを作成し、INDEXMATCHで表示させる。

f:id:abv72:20220125153731p:plain




 

 

*1:$B$2:$B$10=B2)*($C$2:$C$10>C2

VBA100本ノック14本目:社外秘シート削除

excel-ubara.com

 

出題内容

客先へ送付するブックを作成します。
シート名に「社外秘」の文字が含まれるシートを削除してください。
他のシートは計算式を消して値だけにしてください。
※シート間参照の数式あり。
※条件付き書式・入力規則は未使用。
※対象はアクティブブックで構いません。

f:id:abv72:20210926130926p:plain

自分の解答

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 i

    On Error Resume Next
    Sheets(c).Delete
    
    Application.DisplayAlerts = True

End Sub

その他

非表示シートがあるかも

保護がかかっていて削除できないかも

VBA100本ノック13本目:文字列の部分フォント

excel-ubara.com

 

出題内容

選択セル(Selection:複数範囲あり)の文字列に「注意」という文字があった場合は、その「注意」の文字だけを"赤の太字"に設定してください。
セル以外(図形等)が選択されている場合は何もせずに正常終了するようにしてください。

f:id:abv72:20210913115518p:plain





自分の解答

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
    
    Next

End Sub

2つ目の"注意"に対して処理できていない。
図形が選択されている時の対応ができていない。

f:id:abv72:20210913112625p:plain

修正

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
        
    Next

End Sub

 

VBA100本ノック12本目:セル結合を解除

excel-ubara.com

出題内容

#VBA100本ノック 12本目
A1から始まる表範囲のC列に金額が入っています。
しかし、ところどころに結合されたセルがあります。
セル結合を解除し、入っている金額を整数で均等に割り振ってください。(2枚目画像)
端数処理方法は任意とします。
※結合セルには正の整数しか入っていません。

f:id:abv72:20210822133453p:plain

自分の解答

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 としている為、割り算の結果がそのまま各セルに入力される。

小数点ではなく整数で入力したい。

f:id:abv72:20210822133711p:plain

 

修正

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)のズレも大きくなってしまう。

f:id:abv72:20210822134947p:plain

 

VBA100本ノック11本目:セル結合の警告

excel-ubara.com

出題内容

画像のようにシートにはところどころにセル結合があります。
これは放置しておく訳にはいきません。
セル結合されているセルには、メモ(旧コメント)で警告文を出しましょう。
※シートは任意、警告文はご随意に

f:id:abv72:20210817114550p:plain

自分の解答

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本目:行の削除

excel-ubara.com

 

出題内容

画像のように「受注」シートに今月の受注データがあります。
受注数が空欄かつ備考欄に「削除」または「不要」の文字が含まれている行を削除してください。
行の削除は行全体を削除してください。
サンプルでは5行目と10行目を削除

f:id:abv72:20210816132223p:plain

 

自分の解答

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 With

End Sub

 修正箇所

①処理開始前にフィルターを解除しておくコードを追加。

 

Offset後に削除している為、一行下の空行も削除している。
問題がある場合はResizeを使うかIntersectで対応する。

f:id:abv72:20210816132746p:plain