【関数】フィルターをかけたときのカウント

フィルターをかけたシートの値をカウントする場合、
countifなどを使っても全てのデータがカウントされる。
絞り込んだときに見えている部分をカウントしたい。

参照元：https://oshiete.goo.ne.jp/qa/5151705.html



通常は、SUBTOTAL関数を使用する。
しかし限界がある。
そこで、SUBTOTALにcountifを組み合わせる。
=SUMPRODUCT(SUBTOTAL(3,OFFSET($L$1,ROW(INDIRECT("1:"&ROWS($L$2:$L$1000))),))*($L$2:$L$1000=1))


この式を使うとアンケートの集計などが、テーブルをそのままで参照できることができる。
今までは、テーブルで絞り込んだデータを別シートにコピーして、それをカウントしていた。
上記の関数を使うと余分なシートを作らなくて済む。

ここから下は自分しか分からない言葉になっているので他人が見ても理解不能。
しかし注意が必要！①アンケートの場合・・・
そう思われた理由を教えてください(複数選択)
1･2を選択した方
3･4を選択した方
この問いがやっかいである

1･2を選択・・・これはフラグを立てた列を参照させる
下記の場合、BH列に1･2を選択して回答している場合にフラグが立っている。
V列は回答列である。
SUMPRODUCT(SUBTOTAL(3,OFFSET(tテーブル!$BH$1,ROW(INDIRECT("1:"&ROWS(tテーブル!$BH$2:$BH$10000))),))*(tテーブル!$BH$2:$BH$10000=1)*(tテーブル!$V$2:$V$10000=B135))

次に無回答の場合は
=SUMPRODUCT(SUBTOTAL(3,OFFSET(tテーブル!$BH$1,ROW(INDIRECT("1:"&ROWS(tテーブル!$BH$2:$BH$10000))),))*(tテーブル!$BH$2:$BH$10000=1)*(tテーブル!$U$2:$U$10000<>""))


(tテーブル!$U$2:$U$10000<>""))を(tテーブル!$U$2:$U$10000＝0))にすると
空白セルまでカウントされてします。
そこで空白以外をカウントするようにすればよい。
10000＝0　　0だったら
10000<>""　空白以外

【マクロ】シェイプの位置・線色・塗りつぶしの色 等を設定

For Each で総当りで調べている。

シェイプの名前：　Name
表示：　Visible

左位置：　Left
上位置：　Top
幅：　Width
高さ：　Height
角度：　Rotation

線の太さ：　Line.Weight
点線のスタイル：　Line.DashStyle
線種：　Line.Style
線の透明度：　Line.Transparency
線の表示：　Line.Visible
線色：　Line.ForeColor.RGB

塗りつぶし：　Fill.Visible
塗りの透明度：　Fill.Transparency = 0
塗りつぶし色：　Fill.ForeColor.RGB

Private Sub ExShape()
    Dim t As Object
    Dim s As String
    
    For Each t In Sheets("Sheet3").Rectangles
        'シェイプの名前
        s = t.Name
        
        If s = "Rectangle 1" Then
            '表示
            t.Visible = True
            
            '位置
            t.ShapeRange.Left = 132
            t.ShapeRange.Top = 135
            t.ShapeRange.Width = 49.5
            t.ShapeRange.Height = 88.5
            '角度
            t.ShapeRange.Rotation = 0
            
            '線　太さ
            t.ShapeRange.Line.Weight = 0.75
            '点線のスタイル
            t.ShapeRange.Line.DashStyle = msoLineSolid
            '線種
            t.ShapeRange.Line.Style = msoLineSingle '1本線
            '透明度
            t.ShapeRange.Line.Transparency = 0  '0.0 (不透明) ～ 1.0 (透明)
            '線の表示
            t.ShapeRange.Line.Visible = True
            '線色
            t.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
            
            '塗りつぶし
            t.ShapeRange.Fill.Visible = True
            '透明度
            t.ShapeRange.Fill.Transparency = 0
            '塗りつぶし色
            t.ShapeRange.Fill.ForeColor.RGB = RGB(255, 210, 1)
            
            Exit For
        
        End If
    Next
   
End Sub

【マクロ】配列格納、呼び出し

配列に入れて特定数を呼び貼り付ける。

Dim buf As Variant
buf = Range("B1:C20") '配列に入れる範囲
Range("H1").Resize(11, 2).Value = buf '配列から特定数を呼び貼り付ける

B1からC20までを配列に格納し
その中から10行分を呼び貼り付ける。
配列は0から始まるので　Resize(11　となる。

【マクロ】フィルター関連

フィルターをかけた箇所の項目名と何で絞ったかを抽出する。


Sub フィルター項目抽出()


Dim srcWS As Worksheet
Set srcWS = ActiveSheet

Dim dstWS As Worksheet
Set dstWS = Worksheets("Sheet3")


Dim i As Long
Dim r As Long
r = 2
With srcWS.AutoFilter
For i = 1 To .Filters.Count
If .Filters(i).On = True Then
If .Filters(i).Operator <> 0 Then
If .Filters(i).Operator = xlFilterValues Then
dstWS.Cells(r, "B").Value = Replace(.Range.Cells(1, i).Value & "：" & Join(.Filters(i).Criteria1, "･"), "=", "")
Else
dstWS.Cells(r, "B").Value = Replace(.Range.Cells(1, i).Value & "：" & .Filters(i).Criteria1 & "･" & .Filters(i).Criteria2, "=", "")
End If
Else
dstWS.Cells(r, "B").Value = Replace(.Range.Cells(1, i).Value & "：" & .Filters(i).Criteria1, "=", "")
End If
r = r + 1
End If
Next
End With
End Sub


上で抽出した値を区切るコード
"："で区切る。

Sub MojiBunkatu()
    Dim lr As Long
    Dim lc As Long
    Dim ar As Variant
    Dim i As Long
   
    lr = 2
    Do
        ar = Split(Cells(lr, 2), "：")
       
        i = 0
        For i = LBound(ar) To UBound(ar)
            Cells(lr, 3 + i) = ar(i)
        Next i
       
        lr = lr + 1
        If Cells(lr, 2) = "" Then
            Exit Do
        End If
    Loop
   
End Sub

最終的には上と下を合体させてひとつのマクロにするかな。

【マクロ】スライサーの挿入と位置取り

下記のコードでスライサーを挿入する。

Worksheets("あいう").Select
Range("S8:AD50").Select
If TypeName(Selection) <> "Range" Then Exit Sub
For Each shp In ActiveSheet.Shapes
' 図形の配置されているセル範囲をオブジェクト変数にセット
Set Rng = Range(shp.TopLeftCell, shp.BottomRightCell)
' 図形の配置されているセル範囲と
' 選択されているセル範囲が重なっているときに図形を削除
If Not (Intersect(Rng, Selection) Is Nothing) Then
shp.Delete
End If
Next
Range("K1").Select
Worksheets("テーブル").Select
ActiveWorkbook.SlicerCaches.Add2(ActiveSheet.ListObjects("テーブル"), "月"). _
Slicers.Add Worksheets("あいう"), , "月", "月7", 157, 1136, 216, 175

テーブルの項目「月」のスライサーを挿入する。
しかし、既に「月」のスライサーが存在している場合、
"月", "月7"としておくと、「月7」と別名でスライサーを挿入してくれる。
この１行で同じ項目のスライサーが2個作れる。

次にスライサーの位置だが、157, 1136, 216, 175
左から上からの位置,左からの位置,幅,高さとなっている。
これはセルの位置座標を表している。
オブジェクト座標ではないので注意が必要だ。

そこでセルの位置を取得するコードが下記だ。
調べたいセルを選択し実行する。

Sub 座標取得()
With Selection
MsgBox "行1端からの座標は" & .Top & "ポイントです。" & vbCrLf & _
       "A列端からの座標は" & .Left & "ポイントです。" & vbCrLf & _
       "セル範囲の高さの座標は" & .Height & "ポイントです。" & vbCrLf & _
       "セル範囲の幅の座標は" & .Width & "ポイントです。"
End With
End Sub

行1端からの座標は144ポイント。　　　　上からの位置
A列端からの座標は1136.25ポイント。　　右からの位置
セル範囲の高さの座標は175.5ポイント。　図形の高さ
セル範囲の幅の座標は216ポイント。　　　図形の幅

MsgBoxの箇所をDebug.Printにすると
イミディエイトウィンドウに書き込まれる。

Sub 座標取得()
With Selection
Debug.Print "上から" & .Top & "ポイント。" & vbCrLf & _
       "右から" & .Left & "ポイント。" & vbCrLf & _
       "高さ" & .Height & "ポイント。" & vbCrLf & _
       "幅" & .Width & "ポイント。"
End With
End Sub

こちらの方が使い勝手が良いだろう。



スライサーの削除は

ActiveSheet.Shapes.Range(Array("日", "市", "地区")).Delete

これを使っているが・・・他にコードあるのか・・・。

【マクロ】スクロールに合わせてオブジェクトが追従

シートをスクロールするとオブジェクトが合わせてついてくる。
下記の場合はカメラで表(右側小さい表)を貼り付けているので
参照表の値が変わってもオブジェクトの値も変わってくれる。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet
.Shapes("表1").Top = .Cells(ActiveWindow.ScrollRow + 3, ActiveWindow.ScrollColumn + 6).Top
.Shapes("表1").Left = .Cells(ActiveWindow.ScrollRow + 3, ActiveWindow.ScrollColumn + 6).Left
End With
End Sub

【関数】複数の検索値から該当するものを全て抽出

A1の値をF列から検索し合致した隣のセルを全て返す。

=IF(COUNTIF($G$2:G29,$B$2)<ROW(B1),"",OFFSET(B1,MATCH($B$2,$G$2:G29,0),6))

A1にbbbと入れるとG列の123456が返る。

シート2にデータがある場合
=IF(COUNTIF(Sheet2!$A$2:A30,$B$3)<ROW(Sheet2!A1),"",OFFSET(Sheet2!A1,MATCH($B$3,Sheet2!$A$2:A30,0),1))

	A	B	C	D	E	F	G
１	aaa	a				aaa	a
２		b				aaa	b
3		c				aaa	c
4		d				aaa	d
5		e				aaa	e
6						bbb	1
7						bbb	2
8						bbb	3
9						bbb	4
10						bbb	5
11						bbb	6