Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7532 / 13645 ツリー ←次へ | 前へ→

【38421】オートフィルタで絞り込んだデータで、特... EBI 06/6/2(金) 11:25 質問[未読]
【38422】Re:オートフィルタで絞り込んだデータで、... Jaka 06/6/2(金) 12:44 発言[未読]
【38431】Re:オートフィルタで絞り込んだデータで、... Kein 06/6/2(金) 17:11 回答[未読]
【38460】Re:オートフィルタで絞り込んだデータで... kobasan 06/6/3(土) 13:48 発言[未読]
【38462】Re:オートフィルタで絞り込んだデータで... EBI 06/6/3(土) 14:38 発言[未読]
【38463】Re:オートフィルタで絞り込んだデータで... Kein 06/6/3(土) 14:44 発言[未読]
【38465】Re:オートフィルタで絞り込んだデータで... kobasan 06/6/3(土) 15:49 回答[未読]
【38468】Re:オートフィルタで絞り込んだデータで... EBI 06/6/3(土) 16:15 発言[未読]
【38470】Re:オートフィルタで絞り込んだデータで... kobasan 06/6/3(土) 16:41 回答[未読]
【38471】Re:オートフィルタで絞り込んだデータで... Kein 06/6/3(土) 16:54 回答[未読]
【38472】Re:オートフィルタで絞り込んだデータで... EBI 06/6/3(土) 17:34 発言[未読]
【38475】Re:オートフィルタで絞り込んだデータで... Kein 06/6/3(土) 19:01 回答[未読]
【38476】Re:オートフィルタで絞り込んだデータで... EBI 06/6/3(土) 21:06 発言[未読]
【38479】Re:オートフィルタで絞り込んだデータで... Kein 06/6/3(土) 22:39 回答[未読]
【38480】Re:オートフィルタで絞り込んだデータで... Kein 06/6/3(土) 22:50 発言[未読]
【38484】Re:オートフィルタで絞り込んだデータで... EBI 06/6/4(日) 8:58 発言[未読]
【38485】Re:オートフィルタで絞り込んだデータで... Kein 06/6/4(日) 13:16 発言[未読]
【38486】Re:オートフィルタで絞り込んだデータで... EBI 06/6/4(日) 14:54 発言[未読]
【38487】Re:オートフィルタで絞り込んだデータで... Kein 06/6/4(日) 15:34 回答[未読]
【38488】Re:オートフィルタで絞り込んだデータで... EBI 06/6/4(日) 16:02 発言[未読]
【38490】Re:オートフィルタで絞り込んだデータで... Kein 06/6/4(日) 17:25 回答[未読]
【38491】Re:オートフィルタで絞り込んだデータで... EBI 06/6/4(日) 19:36 発言[未読]
【38492】Re:オートフィルタで絞り込んだデータで... Kein 06/6/4(日) 21:50 発言[未読]
【38496】Re:オートフィルタで絞り込んだデータで... EBI 06/6/5(月) 10:36 発言[未読]
【38510】Re:オートフィルタで絞り込んだデータで... EBI 06/6/5(月) 14:56 発言[未読]
【38513】Re:オートフィルタで絞り込んだデータで... Kein 06/6/5(月) 16:03 回答[未読]
【38517】Re:オートフィルタで絞り込んだデータで... EBI 06/6/5(月) 17:05 お礼[未読]

【38421】オートフィルタで絞り込んだデータで、特...
質問  EBI  - 06/6/2(金) 11:25 -

引用なし
パスワード
   以下のようにA列の日付でFilterをかけたデータの中で、"受付""適合""不備"の
それぞれの件数を一覧にするには?

  A   B   C  D

  5/3  山田 ・・ 受付
  5/4  伊藤 ・・ 適合
  5/5  高橋 ・・ 受付
  5/5  佐藤 ・・ 不備
 5/10  高木 ・・ 受付
 5/20  木村 ・・ 受付
  6/9  加藤 ・・ 適合
 6/15  河合 ・・ 不備


5/1〜5/31でFilterをかけると、6件のデータが表示されますが、ここで

受付 4件
適合 1件
不備 1件

のようにしてD列のそれぞれの件数を一覧で表示する(sheet2へ)にはどうすればよいでしょうか。

SUBTOTAL関数だけでは出来ないし、COUNT関数では6月の件数も数えられてしまうし、
悩んでいます。VBAではできるでしょうか?

Excelは2003です。

【38422】Re:オートフィルタで絞り込んだデータで...
発言  Jaka  - 06/6/2(金) 12:44 -

引用なし
パスワード
   データ数やこの関数の数が多かったりすると、重いかもしれないけど、
こんな風でも良いんじゃないかと....。
なんだったら、マクロで計算させても良いし。

=SUMPRODUCT((A1:A8>=DATEVALUE("2006/5/1"))*(A1:A8<DATEVALUE("2006/6/1"))*(D1:D8="適合"))
=SUMPRODUCT((A1:A8>=DATEVALUE("2006/5/1"))*(A1:A8<DATEVALUE("2006/6/1"))*(D1:D8="不備"))

【38431】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/2(金) 17:11 -

引用なし
パスワード
   数式でやった方が簡単ですが、VBAの掲示板なので一応サンプルコードを
提示します。実行すると入力フォームが出てくるので、集計したい月を入力
して下さい。
なお、その表は「一行目が項目」になっているという前提です。
そうでないと、フィルターをかけてもきちんと抽出できないので
>5/1〜5/31でFilterをかけると
と矛盾してしまうからです。

Sub My集計()
  Dim Mth As Long, LstR As Long, Clc As Long
  Dim MyR As Range, C As Range
  Dim MyV As Variant
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"
 
  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Sheets("Sheet2")
   .Range("A:A").ClearContents
   .Range("A1").Value = Mth & "月の集計"
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("D1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal 4, xlCount, Array(4)
  End With
  Set MyR = Range(Cells(2, Clc), _
  Cells(65536, Clc).End(xlUp)).SpecialCells(4)
  For Each C In MyR
   If C.Offset(-1).Value = Mth Then
     MyV = Array(Cells(C.Row - 1, 4).Value, _
     Cells(C.Row, 4).Value & " 件")
     Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1) _
     .Resize(, 2).Value = MyV
   ElseIf C.Offset(-1).Value > Mth Then
     Exit For
   End If
  Next
  Set MyR = Nothing: Columns(Clc).ClearContents
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
ELine:
  Application.ScreenUpdating = True
End Sub

【38460】Re:オートフィルタで絞り込んだデータで...
発言  kobasan  - 06/6/3(土) 13:48 -

引用なし
パスワード
   EBI さん 今日は、

> 受付 4件
> 適合 1件
> 不備 1件
>
>のようにしてD列のそれぞれの件数を一覧で表示する(sheet2へ)にはどうすればよいでしょうか。

>悩んでいます。VBAでできるでしょうか?

「件数を一覧で表示する」とありますが、

    1月    2月    3月    4月    5月    6月 ・・・ 12月
受付                    4        
適合                    1    1    
不備                    1    1    

のようなクロス集計の形で表示するのでしょうか。

【38462】Re:オートフィルタで絞り込んだデータで...
発言  EBI E-MAIL  - 06/6/3(土) 14:38 -

引用なし
パスワード
   ▼kobasan さん:ありがとうございます。

>「件数を一覧で表示する」とありますが、
>
>    1月    2月    3月    4月    5月    6月 ・・・ 12月
>受付                    4        
>適合                    1    1    
>不備                    1    1    
>
>のようなクロス集計の形で表示するのでしょうか。

これだとJakaさんのご指摘でできましたが、クロス集計ではなく
keinさんからいただいたように一ヶ月分だけをsheet2に集計させてカメラボタンでsheet1の1行目に表示させたいわけです。
keinさんのコードを試していますが、ちょっとうまく集計してくれません。
5月がうまくできても、7月をやってみるとダメだったり。

【38463】Re:オートフィルタで絞り込んだデータで...
発言  Kein  - 06/6/3(土) 14:44 -

引用なし
パスワード
   >5月がうまくできても、7月をやってみるとダメだったり。
実際のデータはどうなってますか ? 長くなるようなら端折ってもいいですが、
7月分については全部のレコードを書いて下さい。こちらで再度テストしてみます。

【38465】Re:オートフィルタで絞り込んだデータで...
回答  kobasan  - 06/6/3(土) 15:49 -

引用なし
パスワード
   今日は。

>クロス集計ではなく
>keinさんからいただいたように一ヶ月分だけをsheet2に集計させてカメラボタンでsheet1の1行目に表示させたいわけです。

オートフィルタは使っていませんが、これでどうですか。

sheet2へ表示するようにしました。
sheet1の1行目は項目行です。

Sub test()
Dim dic As Object
Dim rngA As Range, r As Range
Dim dkey As String, m As String
Dim v, vnt, outvnt
  '
  m = InputBox("抽出する月を入力", "1〜12を入力", 5)
  Set rngA = ActiveSheet.Range("A2", Range("A65536").End(xlUp))
  Set dic = CreateObject("Scripting.Dictionary")
  vnt = Array("月", "受付", "適合", "不備")
  For Each v In vnt
    dic(m & v) = Empty
  Next
  dic(m & "月") = m & "月"
  '
  For Each r In rngA.Cells
    dkey = Split(r.Text, "/")(0) & r.Offset(, 3).Text
    dic(dkey) = dic(dkey) + 1  '集計
  Next
  '
  With Sheets("Sheet2")
    .Cells.Clear
    .Range("A1").Resize(4).Value _
            = Application.Transpose(vnt)
    .Range("B1").Resize(4).Value _
            = Application.Transpose(dic.items)
    .Select
  End With
  '
  Set r = Nothing
  Set dic = Nothing
  Set rngA = Nothing
End Sub

【38468】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/3(土) 16:15 -

引用なし
パスワード
   ▼kobasan さん:ありがとうございます。

sheet2に月、受付、適合、不備は表示されましたが件数(数字)がでません。

keinさんへ以下のテストデータでどうでしょうか。

日付    氏名    ほか    内容
2006/5/3    山田    ・・    受付
2006/5/4    伊藤    ・・    適合
2006/5/10    花子    ・・    不備
2006/5/22    遠藤    ・・    適合
2006/6/9    加藤    ・・    適合
2006/6/15    河合    ・・    受付
2006/6/16    佐藤    ・・    不備
2006/6/20    高橋    ・・    不備
2006/7/1    種田    ・・    不備
2006/7/4    玉置    ・・    受付
2006/7/15    なぜか    ・・    適合
2006/7/20    きき    ・・    適合
2006/7/22    へんだ    ・・    受付

sheet2には以下のようになります。
            
7月の集計    
受付    2 件
適合    2 件
    2 件

7月の集計    
受付    2 件
適合    2 件
    1 件

このように決まっていません。

【38470】Re:オートフィルタで絞り込んだデータで...
回答  kobasan  - 06/6/3(土) 16:41 -

引用なし
パスワード
   今日は、

>sheet2に月、受付、適合、不備は表示されましたが件数(数字)がでません。
>
>keinさんへ以下のテストデータでどうでしょうか。
>
>日付    氏名    ほか    内容
>2006/5/3    山田    ・・    受付
>2006/5/4    伊藤    ・・    適合
>2006/5/10    花子    ・・    不備
>2006/5/22    遠藤    ・・    適合
>2006/6/9    加藤    ・・    適合
>2006/6/15    河合    ・・    受付
>2006/6/16    佐藤    ・・    不備
>2006/6/20    高橋    ・・    不備
>2006/7/1    種田    ・・    不備
>2006/7/4    玉置    ・・    受付
>2006/7/15    なぜか    ・・    適合
>2006/7/20    きき    ・・    適合
>2006/7/22    へんだ    ・・    受付
>

初めの日付の書式
 A   B   C  D

  5/3  山田 ・・ 受付
  5/4  伊藤 ・・ 適合

と、この日付の書式

日付    氏名    ほか    内容
2006/5/3    山田    ・・    受付
2006/5/4    伊藤    ・・    適合

とが、ちがうために集計されないのです。


    dkey = Split(r.Text, "/")(0) & r.Offset(, 3).Text    'A列の書式は文字列 m/d



    dkey = Split(r.Text, "/")(1) & r.Offset(, 3).Text   'A列の書式は文字列 yyyy/m/d
                   ~~~~                            ~~~~~~~~~~

に変更してください。

【38471】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/3(土) 16:54 -

引用なし
パスワード
   それでうまくいかない理由がわかりました。一番最後のデータの月を指定したとき、
空白セル範囲(MyR)の設定が、一つ不足してしまうことが原因でした。
それで以下のように修正したところ、うまくいきました。

Sub My集計()
  Dim Mth As Long, LstR As Long, Clc As Long
  Dim MyR As Range, C As Range
  Dim MyV As Variant
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"
 
  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Sheets("Sheet2")
   .Range("A:A").ClearContents
   .Range("A1").Value = Mth & "月の集計"
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("D1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal 4, xlCount, Array(4)
  End With
  With Cells(65536, Clc).End(xlUp)
   If .Value = Mth Then
     Set MyR = Range(Cells(2, Clc), .Cells.Offset(1)) _
     .SpecialCells(4)
   Else
     Set MyR = Range(Cells(2, Clc), .Cells).SpecialCells(4)
   End If
  End With
  For Each C In MyR
   If C.Offset(-1).Value = Mth Then
     MyV = Array(Cells(C.Row - 1, 4).Value, _
     Cells(C.Row, 4).Value & " 件")
     Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1) _
     .Resize(, 2).Value = MyV
   ElseIf C.Offset(-1).Value > Mth Then
     Exit For
   End If
  Next
  Set MyR = Nothing: Columns(Clc).ClearContents
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
  Sheets("Sheet2").Activate
ELine:
  Application.ScreenUpdating = True
End Sub

【38472】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/3(土) 17:34 -

引用なし
パスワード
   ▼Kein さん:ありがとうございます。
>それでうまくいかない理由がわかりました。一番最後のデータの月を指定したとき、
>空白セル範囲(MyR)の設定が、一つ不足してしまうことが原因でした。
>それで以下のように修正したところ、うまくいきました。
>

最後の行に一ヶ月に1個だけのデータを入れるとうまくいきません。

2006/7/22    へんだ    ・・    受付
2006/8/1    最終か    ・・    不備

上のように2006/8/1のデータを入れると、7月も8月もうまくいきません。

【38475】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/3(土) 19:01 -

引用なし
パスワード
   あー・・それは「7月でテストした後に続けて8月もテストした」場合ですね ?
それは Sheet2 の B列まで含めてクリアしてなかったことが原因です。
で、今度は他シートへの転記を止めて、表のあるシート上にテキストボックスを
配置し、そこへ結果を表示する形にしてみました。

Sub My集計2()
  Dim Mth As Long, LstR As Long, Clc As Long
  Dim MyR As Range, C As Range
  Dim MyV As String
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"

  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("D1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal 4, xlCount, Array(4)
  End With
  With Cells(65536, Clc).End(xlUp)
   If .Value = Mth Then
     Set MyR = Range(Cells(2, Clc), .Cells.Offset(1)) _
     .SpecialCells(4)
   Else
     Set MyR = Range(Cells(2, Clc), .Cells).SpecialCells(4)
   End If
  End With
  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Text = ""
   ElseIf .Count = 0 Then
     .Add 0, 0, 200, 100
   End If
  End With
  MyV = "[ " & Mth & "月の集計 ]" & vbLf
  For Each C In MyR
   If C.Offset(-1).Value = Mth Then
     MyV = MyV & Cells(C.Row - 1, 4).Value & " : " & _
     Cells(C.Row, 4).Value & " 件" & vbLf
   ElseIf C.Offset(-1).Value > Mth Then
     Exit For
   End If
  Next
  MyV = Left$(MyV, Len(MyV) - 1)
  With ActiveSheet.TextBoxes(1)
   .Text = MyV
   .AutoSize = True
   .Shadow = True
   .Interior.ColorIndex = 20
  End With
  Set MyR = Nothing: Columns(Clc).ClearContents
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
ELine:
  Application.ScreenUpdating = True
End Sub

↓こちらは表のあるシートのシートモジュールに入れて下さい。

Private Sub Worksheet_Activate()
  ActiveSheet.TextBoxes.Delete
End Sub

【38476】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/3(土) 21:06 -

引用なし
パスワード
   ▼Kein さん:いろいろありがとうございます。
訳あってD列の前に2列挿入してデータを入れることになりました。
コードは修正してできるようになったのですが、F列(旧D列)のデータをすべて同じものであった場合にコードがエラーになります。(F列をすべて”適合”とする)

Set MyR = Range(Cells(2, Clc), .Cells).SpecialCells(4) ←ここで止まります。

修正が一部間違っているのでしょうか?

【38479】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/3(土) 22:39 -

引用なし
パスワード
   列の変更も含めて、大幅にロジックを変更してみました。

Sub My集計2()
  Dim Mth As Long, LstR As Long
  Dim Clc As Long, y As Long, CR As Long
  Dim x As Variant
  Dim MyR As Range, C As Range
  Dim MyV As String
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"

  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("F1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal 6, xlCount, Array(6), False
   .Subtotal 4, xlCount, Array(4)
  End With
  x = Application.Match(Mth, Columns(Clc), 0)
  y = Columns(Clc).Find(Mth, , xlValues, xlWhole, , xlPrevious).Row
  Set MyR = Range(Cells(x, Clc), Cells(y, Clc)).SpecialCells(2)
  MyV = "[ " & Mth & "月の集計 ]" & vbLf
  If x = y Then
   MyV = MyV & Cells(x, 6).Value & " : 1 件"
  ElseIf MyR.Areas.Count = 1 Then
   MyV = MyV & Cells(x, 6).Value & _
   " : " & MyR.Cells.Count & " 件"
  Else
   For Each C In MyR.Areas
     CR = C.Row + C.Cells.Count
     MyV = MyV & Cells(CR - 1, 6).Value & " : " & _
     Cells(CR, 6).Value & " 件" & vbLf
   Next
   MyV = Left$(MyV, Len(MyV) - 1)
  End If
  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Item(1).Text = ""
   ElseIf .Count = 0 Then
     .Add 0, 0, 200, 100
   End If
   With .Item(1)
     .Text = MyV
     .AutoSize = True
     .Shadow = True
     .Interior.ColorIndex = 20
   End With
  End With
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
  Set MyR = Nothing: Columns(Clc).ClearContents
ELine:
  Application.ScreenUpdating = True
End Sub

【38480】Re:オートフィルタで絞り込んだデータで...
発言  Kein  - 06/6/3(土) 22:50 -

引用なし
パスワード
   ちょっとテキストボックスを設定するところのコードを、改良します。

With ActiveSheet.TextBoxes



End With


  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Item(1).Text = MyV
   ElseIf .Count = 0 Then
     With .Add(0, 0, 200, 100)
      .Text = MyV
      .AutoSize = True
      .Shadow = True
      .Interior.ColorIndex = 20
     End With
   End If
  End With

と、変更して下さい。
なお念の為言っておきますが、その表を作成しているシートには図形描画の
テキストボックスを、手作業や他のマクロによって配置しないで下さい。

【38484】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/4(日) 8:58 -

引用なし
パスワード
   ▼Kein さん:大変お世話になっています。

ちょっとうまくいきません。
件数が出てきません。また、”受付”などが複数出てきます。

[ 7月の集計 ]
受付 : 件
受付 : 件
適合 : 件
不備 : 件
不備 : 件

【38485】Re:オートフィルタで絞り込んだデータで...
発言  Kein  - 06/6/4(日) 13:16 -

引用なし
パスワード
   んー・・おかしいですね。こちらでは何度かテストしてからUPしてるのですが・・。
表の現状はどうなってますか ? 加工することなく、再度提示してみて下さい。

【38486】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/4(日) 14:54 -

引用なし
パスワード
   ▼Kein さん:お世話様です。
>んー・・おかしいですね。こちらでは何度かテストしてからUPしてるのですが・・。
>表の現状はどうなってますか ? 加工することなく、再度提示してみて下さい。

日付    氏名    ほか    番号    支店    内容
2006/5/3    山田    ・・    222    ・・    受付
2006/5/4    伊藤    ・・    333    ・・    不備
2006/5/10    花子    ・・    444    ・・    適合
2006/5/22    遠藤    ・・    555    ・・    受付
2006/6/3    よーーし    ・・    110    ・・    不備
2006/6/9    加藤    ・・    666    ・・    適合
2006/6/15    河合    ・・    777    ・・    受付
2006/6/16    佐藤    ・・    888    ・・    不備
2006/6/20    高橋    ・・    999    ・・    適合
2006/7/1    米米    ・・    12    ・・    受付
2006/7/4    玉置    ・・    123    ・・    不備
2006/7/15    なぜか    ・・    234    ・・    適合
2006/7/20    きき    ・・    456    ・・    受付
2006/7/22    へんだ    ・・    778    ・・    不備
2006/8/1    最終か    ・・    900    ・・    適合
2006/8/3    これも    ・・    555    ・・    受付

自宅のエクセルは2000でやっています。勤め先は2003なんですが。

【38487】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/4(日) 15:34 -

引用なし
パスワード
   そのデータでやってみたところ、確かに不具合が再現しました。
で、その原因は Subtotalメソッド の引数にあることが分かりました。
ただ、前回のコードでテストした際にも、問題がなかったのが不思議ですが・・。
とにかく今度こそうまくいくと思いますので、以下のコードで試してみて下さい。

Sub My集計3()
  Dim Mth As Long, LstR As Long
  Dim Clc As Long, y As Long, CR As Long
  Dim x As Variant
  Dim MyR As Range, C As Range
  Dim MyV As String
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"

  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("F1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal Clc, xlCount, Array(Clc), False
   .Subtotal 6, xlCount, Array(6)
  End With
  x = Application.Match(Mth, Columns(Clc), 0)
  y = Columns(Clc).Find(Mth, , xlValues, xlWhole, , xlPrevious).Row
  Set MyR = Range(Cells(x, Clc), Cells(y, Clc)).SpecialCells(2)
  MyV = "[ " & Mth & "月の集計 ]" & vbLf
  If x = y Then
   MyV = MyV & Cells(x, 6).Value & " : 1 件"
  ElseIf MyR.Areas.Count = 1 Then
   MyV = MyV & Cells(x, 6).Value & _
   " : " & MyR.Cells.Count & " 件"
  Else
   For Each C In MyR.Areas
     CR = C.Row + C.Cells.Count
     MyV = MyV & Cells(CR - 1, 6).Value & " : " & _
     Cells(CR, 6).Value & " 件" & vbLf
   Next
   MyV = Left$(MyV, Len(MyV) - 1)
  End If
  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Item(1).Text = MyV
   ElseIf .Count = 0 Then
     With .Add(0, 0, 200, 100)
      .Text = MyV
      .AutoSize = True
      .Shadow = True
      .Interior.ColorIndex = 20
     End With
   End If
  End With
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
  Set MyR = Nothing: Columns(Clc).ClearContents
ELine:
  Application.ScreenUpdating = True
End Sub

【38488】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/4(日) 16:02 -

引用なし
パスワード
   なぜか変ですね。5月だけこんなになってしまします。その他はいいんですが。

[ 5月の集計 ]
受付 : 2 件
適合 : 1 件
不備 : 1 件
受付 : 1 件
適合 : 2 件
不備 : 2 件
受付 : 2 件
適合 : 1 件
不備 : 2 件

【38490】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/4(日) 17:25 -

引用なし
パスワード
   あー・・ほんとですね。この原因もやはり Subtotal のところでした。
全ての月でしっかりテストするべきでした。再々で申し訳ないですが、
以下のコードでやってみて下さい。

Sub My集計3()
  Dim Mth As Long, LstR As Long
  Dim Clc As Long, y As Long, CR As Long
  Dim x As Variant
  Dim MyR As Range, C As Range
  Dim MyV As String
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"

  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("IV1").End(xlToLeft).Offset(, 1)
   .Value = "月"
   With .Offset(1).Resize(LstR)
     .Formula = "=MONTH($A2)"
     .Value = .Value
   End With
   If IsError(Application.Match(Mth, .EntireColumn, 0)) Then
     MsgBox "指定した月のデータはありません", 48
     .EntireColumn.ClearContents: GoTo ELine
   End If
  End With
  With Range("A1").CurrentRegion
   Clc = .Columns.Count
   .Sort Key1:=Range("IV1").End(xlToLeft), _
   Order1:=xlAscending, Key2:=Range("F1"), _
   Order2:=xlAscending, Header:=xlYes, _
   Orientation:=xlSortColumns
   .Subtotal Clc, xlCount, Array(Clc), False
   .Subtotal 6, xlCount, Array(6)
  End With
  Range("F2", Range("F65536").End(xlUp)).Offset(, -5) _
  .SpecialCells(4).Offset(, 6).ClearContents
  x = Application.Match(Mth, Columns(Clc), 0)
  y = Columns(Clc).Find(Mth, , xlValues, xlWhole, , xlPrevious).Row
  Set MyR = Range(Cells(x, Clc), Cells(y, Clc)).SpecialCells(2)
  MyV = "[ " & Mth & "月の集計 ]" & vbLf
  If x = y Then
   MyV = MyV & Cells(x, 6).Value & " : 1 件"
  ElseIf MyR.Areas.Count = 1 Then
   MyV = MyV & Cells(x, 6).Value & _
   " : " & MyR.Cells.Count & " 件"
  Else
   For Each C In MyR.Areas
     CR = C.Row + C.Cells.Count
     MyV = MyV & Cells(CR - 1, 6).Value & " : " & _
     C.Cells.Count & " 件" & vbLf
   Next
   MyV = Left$(MyV, Len(MyV) - 1)
  End If
  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Item(1).Text = MyV
   ElseIf .Count = 0 Then
     With .Add(0, 0, 200, 100)
      .Text = MyV
      .AutoSize = True
      .Shadow = True
      .Interior.ColorIndex = 20
     End With
   End If
  End With
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   Range("A2", Range("A65536").End(xlUp).Offset(2)) _
   .SpecialCells(4).EntireRow.Delete xlShiftUp
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
  Set MyR = Nothing: Columns(Clc).ClearContents
ELine:
  Application.ScreenUpdating = True
End Sub

【38491】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/4(日) 19:36 -

引用なし
パスワード
   ▼Kein さん:本当にご苦労さまです。
>あー・・ほんとですね。この原因もやはり Subtotal のところでした。
>全ての月でしっかりテストするべきでした。再々で申し訳ないですが、

1月〜12月までのデータを入れてみました。
1月から5月までは正常に表示されません。(6月〜12月はOKです)

【38492】Re:オートフィルタで絞り込んだデータで...
発言  Kein  - 06/6/4(日) 21:50 -

引用なし
パスワード
   こちらでも1〜12月のデータを入れて、ひと月づつテストしてみましたが
全て正常にカウントされていました。ちなみにテストしたデータは

日付    氏名    ほか    番号    支店    内容
2006/1/2    山田    ・・    222    ・・    受付
2006/1/3    伊藤    ・・    333    ・・    不備
2006/1/4    花子    ・・    444    ・・    適合
2006/1/5    遠藤    ・・    555    ・・    受付
2006/1/6    よーーし    ・・    110    ・・    不備
2006/1/7    加藤    ・・    666    ・・    適合
2006/1/8    河合    ・・    777    ・・    受付
2006/1/9    佐藤    ・・    888    ・・    不備
2006/2/1    高橋    ・・    999    ・・    適合
2006/2/2    米米    ・・    12    ・・    受付
2006/2/3    玉置    ・・    123    ・・    不備
2006/2/4    なぜか    ・・    234    ・・    適合
2006/3/2    きき    ・・    456    ・・    受付
2006/3/3    へんだ    ・・    778    ・・    不備
2006/3/4    最終か    ・・    900    ・・    適合
2006/3/5    これも    ・・    555    ・・    受付
2006/3/6    山田    ・・    222    ・・    受付
2006/3/7    伊藤    ・・    333    ・・    不備
2006/3/8    花子    ・・    444    ・・    適合
2006/4/2    遠藤    ・・    555    ・・    受付
2006/4/3    よーーし    ・・    110    ・・    不備
2006/4/4    加藤    ・・    666    ・・    適合
2006/4/5    河合    ・・    777    ・・    受付
2006/4/6    佐藤    ・・    888    ・・    不備
2006/4/7    高橋    ・・    999    ・・    適合
2006/4/8    米米    ・・    12    ・・    受付
2006/4/9    玉置    ・・    123    ・・    不備
2006/4/10    なぜか    ・・    234    ・・    適合
2006/5/3    きき    ・・    456    ・・    受付
2006/5/4    へんだ    ・・    778    ・・    不備
2006/5/10    最終か    ・・    900    ・・    適合
2006/5/22    これも    ・・    555    ・・    受付
2006/6/3    よーーし    ・・    110    ・・    不備
2006/6/9    加藤    ・・    666    ・・    適合
2006/6/15    河合    ・・    777    ・・    受付
2006/6/16    佐藤    ・・    888    ・・    不備
2006/6/20    高橋    ・・    999    ・・    適合
2006/7/1    米米    ・・    12    ・・    受付
2006/7/4    玉置    ・・    123    ・・    不備
2006/7/15    なぜか    ・・    234    ・・    適合
2006/7/20    きき    ・・    456    ・・    受付
2006/7/22    へんだ    ・・    778    ・・    不備
2006/8/1    最終か    ・・    900    ・・    適合
2006/8/3    これも    ・・    555    ・・    受付
2006/9/5    玉置    ・・    123    ・・    受付
2006/9/6    なぜか    ・・    234    ・・    受付
2006/9/7    きき    ・・    456    ・・    不備
2006/9/8    へんだ    ・・    778    ・・    適合
2006/10/1    最終か    ・・    900    ・・    受付
2006/11/3    これも    ・・    555    ・・    不備
2006/11/4    よーーし    ・・    110    ・・    適合
2006/11/5    加藤    ・・    666    ・・    受付
2006/11/6    河合    ・・    777    ・・    不備
2006/11/7    佐藤    ・・    888    ・・    適合
2006/12/9    高橋    ・・    999    ・・    受付
2006/12/10    米米    ・・    12    ・・    不備
2006/12/11    玉置    ・・    123    ・・    適合
2006/12/12    なぜか    ・・    234    ・・    受付
2006/12/13    きき    ・・    456    ・・    不備

です。それで、そちらでもしこのデータで試してうまくいったら、
そちらのデータとどこが違うか比較しなければなりません。
もしうまくいかないようなら、全く違うロジックで組み直そうと
考えてますが、F列に入れる "内容" というのは、上のように種類が
決っているのでしょーか ? 決っているなら全種類を教えて下さい。
めったに入力しないものがあっても、それを含めてです。

【38496】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/5(月) 10:36 -

引用なし
パスワード
   原因わかりました。
職場の同僚がやっていたものにはF列の後(G列)にところどころデータを入れているのを思い出して、G列にデータを入れました。
これが原因ですね。G列を削除するとすべて正常に件数がでました。ありがとうございました。
いま、職場の実際のデータで検証して確認済です。
ところで、このG列も含めてこれを行うにはこのコードのどこを修正すればよろしいでしょうか。
いろいろお世話になります。

【38510】Re:オートフィルタで絞り込んだデータで...
発言  EBI  - 06/6/5(月) 14:56 -

引用なし
パスワード
   .SpecialCells(4).Offset(, 6).ClearContents '←ここをoffset(, 7)に変えました。
一応正常に動いていますが、これでよかったでしょうか。

【38513】Re:オートフィルタで絞り込んだデータで...
回答  Kein  - 06/6/5(月) 16:03 -

引用なし
パスワード
   あ、どーも遅くなりました。一行目の項目が増減(入力している列数が増減)しても、
「A1セルから右へ空白なく連続して項目が入っている」という条件さえ
合致していれば、以下のマクロで大丈夫かと思います。

Sub My集計4()
  Dim Mth As Long, LstR As Long
  Dim Clc As Long, y As Long, CR As Long
  Dim x As Variant
  Dim MyR As Range, C As Range
  Dim MyV As String
  Const Pmt As String = _
  "集計する月を1〜12の整数で入力して下さい"

  With Application
   Do
     Mth = .InputBox(Pmt, Type:=1)
     If Mth = False Then Exit Sub
   Loop While Mth < 1 Or Mth > 12
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  LstR = Range("A65536").End(xlUp).Row - 1
  With Range("A1").CurrentRegion
   Clc = .Columns.Count + 1
   With Cells(1, Clc)
     .Value = "月"
     With .Offset(1).Resize(LstR)
      .Formula = "=MONTH($A2)"
      .Value = .Value
     End With
   End With
   If IsError(Application.Match(Mth, Columns(Clc), 0)) Then
     MsgBox "指定した月のデータはありません", 48
     Columns(Clc).ClearContents: GoTo ELine
   End If
   With .Resize(, Clc)
     .Sort Key1:=Cells(1, Clc), Order1:=xlAscending, _
     Key2:=Cells(1, 6), Order2:=xlAscending, _
     Header:=xlYes, Orientation:=xlSortColumns
     .Subtotal Clc, xlCount, Array(Clc), False
     .Subtotal 6, xlCount, Array(6)
   End With
  End With
  Range("F2", Range("F65536").End(xlUp)).Offset(, -5) _
  .SpecialCells(4).Offset(, Clc - 1).ClearContents
  x = Application.Match(Mth, Columns(Clc), 0)
  y = Columns(Clc).Find(Mth, , xlValues, xlWhole, , xlPrevious).Row
  Set MyR = Range(Cells(x, Clc), Cells(y, Clc)).SpecialCells(2)
  MyV = "[ " & Mth & "月の集計 ]" & vbLf
  If x = y Then
   MyV = MyV & Cells(x, 6).Value & " : 1 件"
  ElseIf MyR.Areas.Count = 1 Then
   MyV = MyV & Cells(x, 6).Value & _
   " : " & MyR.Cells.Count & " 件"
  Else
   For Each C In MyR.Areas
     CR = C.Row + C.Cells.Count
     MyV = MyV & Cells(CR - 1, 6).Value & " : " & _
     C.Cells.Count & " 件" & vbLf
   Next
   MyV = Left$(MyV, Len(MyV) - 1)
  End If
  With ActiveSheet.TextBoxes
   If .Count = 1 Then
     .Item(1).Text = MyV
   ElseIf .Count = 0 Then
     With .Add(0, 0, 200, 100)
      .Text = MyV
      .AutoSize = True
      .Shadow = True
      .Interior.ColorIndex = 20
     End With
   End If
  End With
  With Range("A1").CurrentRegion
   .RemoveSubtotal
   Range("A2", Range("A65536").End(xlUp).Offset(2)) _
   .SpecialCells(4).EntireRow.Delete xlShiftUp
   .Sort Key1:=Range("A1"), Order1:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
  End With
  Set MyR = Nothing: Columns(Clc).ClearContents
ELine:
  With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With
End Sub

【38517】Re:オートフィルタで絞り込んだデータで...
お礼  EBI  - 06/6/5(月) 17:05 -

引用なし
パスワード
   確認できました。
いろいろと本当にありがとうございました。お礼申し上げます。

7532 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free