Excel VBA質問箱 IV

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

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


8170 / 13644 ツリー ←次へ | 前へ→

【34650】カウント方法について hatena 06/2/9(木) 10:47 発言[未読]
【34655】Re:カウント方法について ichinose 06/2/9(木) 12:58 発言[未読]
【34660】Re:カウント方法について hatena 06/2/9(木) 14:30 質問[未読]
【34667】Re:カウント方法について hatena 06/2/9(木) 15:53 質問[未読]
【34678】Re:カウント方法について ichinose 06/2/9(木) 18:31 発言[未読]
【34710】Re:カウント方法について hatena 06/2/10(金) 12:04 お礼[未読]
【34733】Re:カウント方法について hatena 06/2/10(金) 18:21 質問[未読]
【34752】Re:カウント方法について ichinose 06/2/10(金) 23:29 発言[未読]
【34754】Re:カウント方法について ichinose 06/2/11(土) 5:48 発言[未読]
【34796】Re:カウント方法について hatena 06/2/13(月) 11:39 発言[未読]
【34805】Re:カウント方法について ichinose 06/2/13(月) 14:33 発言[未読]
【34818】Re:カウント方法について hatena 06/2/13(月) 18:42 お礼[未読]
【34662】Re:カウント方法について Kein 06/2/9(木) 15:00 回答[未読]
【34709】Re:カウント方法について hatena 06/2/10(金) 12:02 質問[未読]
【34713】Re:カウント方法について Kein 06/2/10(金) 13:47 回答[未読]
【34715】Re:カウント方法について hatena 06/2/10(金) 14:33 質問[未読]
【34716】Re:カウント方法について Kein 06/2/10(金) 14:48 回答[未読]

【34650】カウント方法について
発言  hatena  - 06/2/9(木) 10:47 -

引用なし
パスワード
   (A列に)より順次下記のようにデータが入ってます。
3◎



2◎


このカウント方法について教えてください。
尚値は固定ではないので、毎回セルから値をとって、その数を数えたいです。
っで最終行に
3◎-1個
3×-3個...と書かせたい


また応用として

(A列に) (B)
3◎    3
3×    2
3×    2  
3×    1
2◎    1
2×    1
同じく最終行に 
3◎-3の数1個
3×-2の数2個
3×-1の数1個
・・    とパターンがあるだけ書かせたいのです、

【34655】Re:カウント方法について
発言  ichinose  - 06/2/9(木) 12:58 -

引用なし
パスワード
   ▼hatena さん:
こんにちは。

>(A列に)より順次下記のようにデータが入ってます。
>3◎
>3×
>3×
>3×
>2◎
>2×

標準モジュールに
'==========================================================
Sub main()
  Dim dic As Object
  Dim crng As Range
  Dim rng As Range
  Dim cnt As Long
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
  Set dic = CreateObject("scripting.dictionary")
  With dic
    For Each crng In rng
     If .Exists(CStr(crng.Value)) Then
       .Item(CStr(crng.Value)) = .Item(CStr(crng.Value)) + 1
     Else
       .Add CStr(crng.Value), 1
       End If
     Next
    Range(Cells(rng.Count + 2, 1), Cells(rng.Count + 1 + .Count, 1)).Value = Application.Transpose(.Keys)
    Range(Cells(rng.Count + 2, 2), Cells(rng.Count + 1 + .Count, 2)).Value = Application.Transpose(.Items)
    End With
  Set dic = Nothing
End Sub


>このカウント方法について教えてください。
>尚値は固定ではないので、毎回セルから値をとって、その数を数えたいです。
>っで最終行に
>3◎-1個
>3×-3個...と書かせたい
>
>
>また応用として
>
>(A列に) (B)
>3◎    3
>3×    2
>3×    2  
>3×    1
>2◎    1
>2×    1
>同じく最終行に 
>3◎-3の数1個
>3×-2の数2個
>3×-1の数1個

標準モジュールに
'===============================================================
Sub main2()
  Dim dic As Object
  Dim crng As Range
  Dim rng As Range
  Dim cnt As Long
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
  Set dic = CreateObject("scripting.dictionary")
  With dic
    For Each crng In rng
     If .Exists(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) Then
       .Item(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) = .Item(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) + 1
     Else
       .Add CStr(crng.Value & "-" & crng.Offset(0, 1).Value), 1
       End If
     Next
    Range(Cells(rng.Count + 2, 1), Cells(rng.Count + 1 + .Count, 1)).Value = Application.Transpose(.Keys)
    Range(Cells(rng.Count + 2, 2), Cells(rng.Count + 1 + .Count, 2)).Value = Application.Transpose(.Items)
    End With
  Set dic = Nothing
End Sub


いづれも対象シートをアクティブにして実行してみて下さい

【34660】Re:カウント方法について
質問  hatena  - 06/2/9(木) 14:30 -

引用なし
パスワード
   ▼ichinose さん:
すごいですね〜・・
なんかビックリしました。
いままで使ったことのないものばかりで・・驚きました。
っでひとつ質問です。
1行目に項目名とかが入っていたら、どこをどのように治したらよいのでしょうか?

【34662】Re:カウント方法について
回答  Kein  - 06/2/9(木) 15:00 -

引用なし
パスワード
   こんな感じで、どうでしょーか ?

Sub MyCount()
  Dim MyR As Range
  Dim Flg As Boolean
 
  With Range("A:A").SpecialCells(2).Areas
   If .Count > 1 Then .Item(2).Resize(, 2).ClearContents
  End With
  Set MyR = Range("A1").CurrentRegion
  If MyR.ListHeaderRows = 0 Then
   Flg = True: Application.ScreenUpdating = False
   Rows(1).Insert xlShiftDown
   Range("A1").Value = "[COUNT]"
  End If
  Range("A1", Range("A65536").End(xlUp)).AdvancedFilter _
  xlFilterCopy, , Range("A65536").End(xlUp).Offset(2), True
  With Range("A65536").End(xlUp).CurrentRegion
   .Offset(, 1).Formula = _
   "=COUNTIF(" & MyR.Address & "," & .Range("A1").Address(0, 0) & ")"
   .Offset(, 1).Value = .Offset(, 1).Value
   .Offset(, 1).Range("A1").ClearContents
  End With
  If Flg Then
   Rows(1).Delete xlShiftUp
   Application.ScreenUpdating = True
  End If
  Set MyR = Nothing
End Sub

【34667】Re:カウント方法について
質問  hatena  - 06/2/9(木) 15:53 -

引用なし
パスワード
   ▼ichinose さん:
たびたびすみません

結果を並べ替えをして表示させることは可能ですか?
今は、セルの順に
3◎ 1
3× 1
2◎ 3
ですが
2◎ 3
3◎ 1
3× 1
とさせたいのです。

【34678】Re:カウント方法について
発言  ichinose  - 06/2/9(木) 18:31 -

引用なし
パスワード
   ▼hatena さん:
こんばんは。

>たびたびすみません
>
>結果を並べ替えをして表示させることは可能ですか?
>今は、セルの順に
>3◎ 1
>3× 1
>2◎ 3
>ですが
>2◎ 3
>3◎ 1
>3× 1
>とさせたいのです。
Excelは並べ替えができますよね?


この前のご質問と合わせて(1行目が項目名の場合)・・・、

'=================================
Sub main()
  Dim dic As Object
  Dim crng As Range
  Dim rng As Range
  Dim cnt As Long
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Set dic = CreateObject("scripting.dictionary")
    With dic
     For Each crng In rng
       If .Exists(CStr(crng.Value)) Then
        .Item(CStr(crng.Value)) = .Item(CStr(crng.Value)) + 1
       Else
        .Add CStr(crng.Value), 1
        End If
       Next
     Range(Cells(rng.Count + 3, 1), Cells(rng.Count + 2 + .Count, 1)).Value = Application.Transpose(.Keys)
     Range(Cells(rng.Count + 3, 2), Cells(rng.Count + 2 + .Count, 2)).Value = Application.Transpose(.Items)
     Range(Cells(rng.Count + 3, 1), Cells(rng.Count + 2 + .Count, 2)).Sort Key1:=Cells(rng.Count + 3, 2), Order1:=xlDescending, Header:=xlNo
     '↑ソートする
     End With
    Set dic = Nothing
    End If
End Sub


main2も同じように修正してください。

【34709】Re:カウント方法について
質問  hatena  - 06/2/10(金) 12:02 -

引用なし
パスワード
   ▼Kein さん:
>こんな感じで、どうでしょーか ?
すごいです。私が理解できそうな感じです。ありがとうございました。
しかし、A列とB列の組み合わせのカウントはどのように書き換えたら
よろしいでしょうか?

【34710】Re:カウント方法について
お礼  hatena  - 06/2/10(金) 12:04 -

引用なし
パスワード
   ▼ichinose さん:
ご回答ありがとうございます。
マクロをヘルプを使って理解している最中です。
また分からないことがありましたら、お教えくださればうれしいです。

【34713】Re:カウント方法について
回答  Kein  - 06/2/10(金) 13:47 -

引用なし
パスワード
   例えばA,B列どちらのデータにも、カンマが含まれていなければ、
このように変更します。

Sub MyCount2()
  Dim MyR As Range, C As Range
  Dim Flg As Boolean
  Dim x As Integer
 
  Application.ScreenUpdating = False
  With Range("A:A").SpecialCells(2).Areas
   If .Count > 1 Then .Item(2).Resize(, 2).ClearContents
  End With
  Set MyR = Range("A1").CurrentRegion
  For Each C In MyR
   C.Value = C.Value & "," & C.Offset(, 1).Value
  Next
  If MyR.ListHeaderRows = 0 Then
   Flg = True
   Rows(1).Insert xlShiftDown
   Range("A1").Value = "[COUNT]"
  End If
  Range("A1", Range("A65536").End(xlUp)).AdvancedFilter _
  xlFilterCopy, , Range("A65536").End(xlUp).Offset(2), True
  With Range("A65536").End(xlUp).CurrentRegion
   .Offset(, 1).Formula = _
   "=COUNTIF(" & MyR.Address & "," & .Range("A1").Address(0, 0) & ")"
   .Offset(, 1).Value = .Offset(, 1).Value
   .Offset(, 1).Range("A1").ClearContents
  End With
  If Flg Then Rows(1).Delete xlShiftUp
  For Each C In MyR
   x = InStr(1, C.Value, ",")
   If x > 0 Then C.Value = Left$(C.Value, x - 1)
  Next
  Application.ScreenUpdating = True: Set MyR = Nothing
End Sub

【34715】Re:カウント方法について
質問  hatena  - 06/2/10(金) 14:33 -

引用なし
パスワード
   ▼Kein さん:
ちなみに、B列の場合、AをBに変えてもうまくいきません。
データがAとB列にあり、B列のデータををカウントしたい場合です

【34716】Re:カウント方法について
回答  Kein  - 06/2/10(金) 14:48 -

引用なし
パスワード
   最初の質問は
>A列に) (B)
>3◎    3
>3×    2
>3×    2  
>3×    1
>2◎    1
>2×    1
>同じく最終行に 
>3◎-3の数1個
>3×-2の数2個
>3×-1の数1個
>・・    とパターンがあるだけ書かせたいのです、

ということになってましたよね ? なのでそのように変更したわけですが、
今度は「B列のみの集計」にしたい、という意味でしょーか ? それなら
06/2/9(木) 15:00 に提示したコードを改造して

Sub MyCount3()
  Dim MyR As Range
  Dim Flg As Boolean
 
  With Range("B:B").SpecialCells(2).Areas
   If .Count > 1 Then .Item(2).Resize(, 2).ClearContents
  End With
  Set MyR = Range("B1", Range("B65536").End(xlUp))
  If MyR.ListHeaderRows = 0 Then
   Flg = True: Application.ScreenUpdating = False
   Rows(1).Insert xlShiftDown
   Range("B1").Value = "[COUNT]"
  End If
  Range("B1", Range("B65536").End(xlUp)).AdvancedFilter _
  xlFilterCopy, , Range("B65536").End(xlUp).Offset(2), True
  With Range("B65536").End(xlUp).CurrentRegion
   .Offset(, 1).Formula = _
   "=COUNTIF(" & MyR.Address & "," & .Range("B1").Address(0, 0) & ")"
   .Offset(, 1).Value = .Offset(, 1).Value
   .Offset(, 1).Range("A1").ClearContents
  End With
  If Flg Then
   Rows(1).Delete xlShiftUp
   Application.ScreenUpdating = True
  End If
  Set MyR = Nothing
End Sub

と、すれば良いと思います。あとはこれを応用して、自分で考えてみて下さい。

【34733】Re:カウント方法について
質問  hatena  - 06/2/10(金) 18:21 -

引用なし
パスワード
   ▼ichinose さん:
自分なりに頑張ってみましたが、うまく動きません。
A列 B列とカウントしたいときがあり、このように変えてみました。
っがうまく動きません。どのようにしたら、よろしいでしょうか?
また、今後、C列も増える予定に変更され、AとB列の組合せだけでなく
BとC列の組み合わせもありえるとのことで、変更箇所等を教えてください。
Sub A列()
  抽出 "A"
End Sub
Sub B列()
  抽出 "B"
End Sub
Sub 抽出(RowNo As String)
  Set rng = Range("" & RowNo & "2:" & RowNo & "" & Cells(Rows.Count, 1).End(xlUp).Row & "")

  If rng.Row > 1 Then
    Set dic = CreateObject("scripting.dictionary")
    With dic
      For Each crng In rng
        If .Exists(CStr(crng.Value)) Then  .Item(CStr(crng.Value)) = .Item(CStr(crng.Value)) + 1 
Else
          .Add CStr(crng.Value), 1               
        End If
      Next
            
      Cells(rng.Count + 2, RowNo).Value = Cells(1, RowNo).Value
      Range(Cells(rng.Count + 3, RowNo), Cells(rng.Count + 2 + .Count, RowNo)).Value = Application.Transpose(.Keys)
      Range(Cells(rng.Count + 3, RowNo), Cells(rng.Count + 2 + .Count, 2)).Value = Application.Transpose(.Items)
      Range(Cells(rng.Count + 3, RowNo), Cells(rng.Count + 3 + .Count, 2)).Sort Key1:=Cells(rng.Count + 3, 1), Order1:=xlAscending, Header:=xlNo
      End With
    Set dic = Nothing
  End If
End Sub

【34752】Re:カウント方法について
発言  ichinose  - 06/2/10(金) 23:29 -

引用なし
パスワード
   ▼hatena さん:
こんばんは。

>自分なりに頑張ってみましたが、うまく動きません。
>A列 B列とカウントしたいときがあり、このように変えてみました。
>っがうまく動きません。どのようにしたら、よろしいでしょうか?
>また、今後、C列も増える予定に変更され、AとB列の組合せだけでなく
>BとC列の組み合わせもありえるとのことで、変更箇所等を教えてください。
なるほど・・・、サブプロシジャーにするのは賛成です。
でも、これのインターフェースには悩みますね!!
以下のようにしました。
'================================================================
Sub test1()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Call 集計(rng, 0) 'A列の集計
    end if
End Sub
'===============================================================
Sub test2()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Call 集計(rng, 1) 'B列の集計
    end if
End Sub
'===============================================================
Sub test3()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Call 集計(rng, 2) 'C列の集計
    end if
End Sub
'===============================================================
Sub test4()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Call 集計(rng,0, 2) 'A列とC列の組合せ集計
    end if
End Sub


'=============================================================
Sub 集計(基準セル範囲 As Range, ParamArray 比較列() As Variant)
'基準セル範囲を基準に比較列として指定されたオフセット位置で集計を行う
'Input--基準セル範囲:集計を行う基準になるセル範囲(列方向のセル範囲を指定する例-A1:A6)
'    比較列:集計する列を基準セル範囲からのオフセット値で指定する
' 例1  セル範囲A2:A6を集計する
'    call 集計(range("a1:a6"),0)
'
' 例2  セル範囲b2:b6を集計する
'    call 集計(range("a1:a6"),1)
'  又は call 集計(range("b1:b6"),0)
'
' 例3  セルA2:B6を集計する
'    call 集計(range("a1:a6"),0,1)
'
' 例4  セルA2:A6を基準セルとしてA列とC列で集計する
'    call 集計(range("a1:a6"),0,2)
  Dim dic As Object
  Dim idx As Long
  Dim crng As Range
  Dim cnt As Long
  Dim keystr As String
  Dim s_tag As Variant
  Dim s_val As Variant
  ReDim compstr(0 To UBound(比較列()))
  Set dic = CreateObject("scripting.dictionary")
  With dic
    For Each crng In 基準セル範囲
     For idx = LBound(比較列()) To UBound(比較列())
       compstr(idx) = CStr(crng.Offset(0, 比較列(idx)).Value)
       Next
     keystr = Join(compstr(), "-")
     If .Exists(keystr) Then
       .Item(keystr) = .Item(keystr) + 1
     Else
       .Add keystr, 1
       End If
     Next
    cnt = .Count
    s_tag = Application.Transpose(.keys)
    s_val = Application.Transpose(.items)
    With 基準セル範囲
     .Offset(.Count + 1, 0).Resize(cnt, 1).Value = s_tag
     .Offset(.Count + 1, 1).Resize(cnt, 1).Value = s_val
     .Offset(.Count + 1, 0).Resize(cnt, 2).Sort _
            Key1:=.Offset(.Count + 1, 1), _
            Order1:=xlDescending, Header:=xlNo
       '↑ソートする
     End With
    End With
  Set dic = Nothing
End Sub


確認してみて下さい。

【34754】Re:カウント方法について
発言  ichinose  - 06/2/11(土) 5:48 -

引用なし
パスワード
   おはようございます。
コメントの訂正です。

>'=============================================================
>Sub 集計(基準セル範囲 As Range, ParamArray 比較列() As Variant)
>'基準セル範囲を基準に比較列として指定されたオフセット位置で集計を行う
>'Input--基準セル範囲:集計を行う基準になるセル範囲(列方向のセル範囲を指定する例-A1:A6)
>'    比較列:集計する列を基準セル範囲からのオフセット値で指定する
>' 例1  セル範囲A2:A6を集計する
'    call 集計(range("a2:a6"),0)
>'
>' 例2  セル範囲b2:b6を集計する
'    call 集計(range("a2:a6"),1)
'  又は call 集計(range("b2:b6"),0)
>'
>' 例3  セルA2:B6を集計する
'    call 集計(range("a2:a6"),0,1)
>'
>' 例4  セルA2:A6を基準セルとしてA列とC列で集計する
'    call 集計(range("a2:a6"),0,2)

以上です。失礼しました。

【34796】Re:カウント方法について
発言  hatena  - 06/2/13(月) 11:39 -

引用なし
パスワード
   ▼ichinose さん:
アドバイスありがとうございます。
しかし、実行してみたところ、一行目 - をつけることにより
日付と認識するらしく、5月 日というように項目名が変更されてしまいます。
"-" に" - "スペースを入れてもダメでした
>     keystr = Join(compstr(), "-")
>     If .Exists(keystr) Then
>       .Item(keystr) = .Item(keystr) + 1

【34805】Re:カウント方法について
発言  ichinose  - 06/2/13(月) 14:33 -

引用なし
パスワード
   こんにちは。
>しかし、実行してみたところ、一行目 - をつけることにより
>日付と認識するらしく、5月 日というように項目名が変更されてしまいます。
>"-" に" - "スペースを入れてもダメでした
>>     keystr = Join(compstr(), "-")
>>     If .Exists(keystr) Then
>>       .Item(keystr) = .Item(keystr) + 1

こんな場合ですか?
セルA1から

      A       B
 1   項目1      項目2
 2    1        11
 3    2        12
 4    3        13
 5    4        14
 6    5        15
 7    6        16
 8    7        17


こんなデータが入っているとき、

'==================================
Sub test()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp)) '*
  If rng.Row > 1 Then '*
    Call 集計(rng, 0, 1) 'A列とB列の組合せ集計
    End If
End Sub

を実行すると、
セルA10から、
1月11日
2月12日
3月13日
4月14日
5月15日
6月16日
7月17日

という結果が表示されてしまいます。

とここまで記述して下さい。

入力データが何なのかを明確に記述する事ですよ!!

今回は見当がついたからよかったですけど・・・。


これは、集計プロシジャーを

'================================================================
Sub 集計(基準セル範囲 As Range, ParamArray 比較列() As Variant)
'基準セル範囲を基準に比較列として指定されたオフセット位置で集計を行う
'Input--基準セル範囲:集計を行う基準になるセル範囲(列方向のセル範囲を指定する例-A1:A6)
'    比較列:集計する列を基準セル範囲からのオフセット値で指定する
' 例1  セル範囲A2:A6を集計する
'    call 集計(range("a2:a6"),0)
'
' 例2  セル範囲b2:b6を集計する
'    call 集計(range("a2:a6"),1)
'  又は call 集計(range("b2:b6"),0)
'
' 例3  セルA2:B6を集計する
'    call 集計(range("a2:a6"),0,1)
'
' 例4  セルA2:A6を基準セルとしてA列とC列で集計する
'    call 集計(range("a2:a6"),0,2)
  Dim dic As Object
  Dim idx As Long
  Dim crng As Range
  Dim cnt As Long
  Dim keystr As String
  Dim s_tag As Variant
  Dim s_val As Variant
  ReDim compstr(0 To UBound(比較列()))
  Set dic = CreateObject("scripting.dictionary")
  With dic
    For Each crng In 基準セル範囲
     For idx = LBound(比較列()) To UBound(比較列())
       compstr(idx) = CStr(crng.Offset(0, 比較列(idx)).Value)
       Next
     keystr = Join(compstr(), "-")
     If .Exists(keystr) Then
       .Item(keystr) = .Item(keystr) + 1
     Else
       .Add keystr, 1
       End If
     Next
    cnt = .Count
    s_tag = Application.Transpose(.keys)
    s_val = Application.Transpose(.items)
    With 基準セル範囲
     .Offset(.Count + 1, 0).Resize(cnt, 1).NumberFormatLocal = "@"
'       追加して下さい↑
     .Offset(.Count + 1, 0).Resize(cnt, 1).Value = s_tag
     .Offset(.Count + 1, 1).Resize(cnt, 1).Value = s_val
     .Offset(.Count + 1, 0).Resize(cnt, 2).Sort _
            Key1:=.Offset(.Count + 1, 1), _
            Order1:=xlDescending, Header:=xlNo
       '↑ソートする
     End With
    End With
  Set dic = Nothing
End Sub

【34818】Re:カウント方法について
お礼  hatena  - 06/2/13(月) 18:42 -

引用なし
パスワード
   ありがとうございました。完成しました
言葉や説明が抜けていたにもかかわらず、教えていただきありがとうございました
。次回以降気をつけたいと思います。

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