Excel VBA質問箱 IV

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

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


2519 / 13646 ツリー ←次へ | 前へ→

【67534】出現の名称をDictionaryで出す Yoshim 10/12/11(土) 8:53 質問[未読]
【67535】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 9:50 発言[未読]
【67538】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 10:44 発言[未読]
【67540】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 11:21 発言[未読]
【67537】Re:出現の名称をDictionaryで出す 山猿 10/12/11(土) 10:20 発言[未読]
【67539】Re:出現の名称をDictionaryで出す UO3 10/12/11(土) 11:07 回答[未読]
【67542】Re:出現の名称をDictionaryで出す Yoshim 10/12/11(土) 11:52 お礼[未読]

【67534】出現の名称をDictionaryで出す
質問  Yoshim  - 10/12/11(土) 8:53 -

引用なし
パスワード
   Dictionaryで行き詰っています。よろしくお願いします。

B列に地域名(あ、さ、た、き、す)
C列に商品名(A、B、C型など)

商品名を基準に

商品出現回数_商品名_地域名
   2     A   あ、き、す
   3     C   さ 
   1     B   た

という表に仕上げたいのですが
地域名のところに出すやり方がわかりません、コードにアドバイス入れていただけませんでしょうか・・・

Sub test()
  Dim myR As Range, Mycell As Range
  Dim dic, key
  Dim k As Long
  Dim v 
Set myR = Range("C2" & ":" & "C" & Range("C" & Rows.Count).End(xlUp).Row)
  Set dic = CreateObject("Scripting.Dictionary") 
  For Each Mycell In myR
    v = Mycell.Value
    If v <> "" Then
      dic(v) = dic(v) + 1
    End If
  Next 
  k = 1
  For Each key In dic.Keys
    If dic(key) >= 1 Then
      k = k + 1
      Cells(k, "G").Value = dic(key)
      Cells(k, "H").Value = key
    End If
  Next
End Sub

【67535】Re:出現の名称をDictionaryで出す
発言  kanabun  - 10/12/11(土) 9:50 -

引用なし
パスワード
   ▼Yoshim さん:
>Dictionaryで行き詰っています。
>
>商品出現回数_商品名_地域名
>   2     A   あ、き、す
>   3     C   さ 
>   1     B   た
>
>という表に仕上げたいのですが
>地域名のところに出すやり方がわかりません、

コードには地域名を出力する部分がありませんね?
ご提示のコードをできるだけ活かすとすると、こんな追加で
行けるのでは?

  Dictionaryに 商品をキー登録するとき、対応するアイテムに
  出力先の行番号を登録しておき、商品別に 決められた(一意の)
  行に出現回数のカウント、地域名の出力がされるように管理
  させます。

Sub trial2()
  Dim myR As Range, c As Range, r As Range
  Dim dic As Object, key
  Dim n As Long, k As Long
  Dim v, sLocal As String
  With Range("C:C")
    Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
  End With
  With Range("G1:I1")
    .Resize(100).ClearContents
    .Value = Array("商品出現回数", "商品名", "地域名")
    Set r = .Offset(1)
  End With
  Set dic = CreateObject("Scripting.Dictionary")
  For Each c In myR
    v = c.Value
    If Not IsEmpty(v) Then
      If dic.Exists(v) Then
        k = dic(v)  '出力行番号を取得
      Else
        n = n + 1   '新規出力行番号
        dic(v) = n  '格納
        k = n
        r.Item(k, 2) = v
      End If
      r.Item(k, 1) = r.Item(k, 1).Value + 1 '出現回数
      sLocal = r.Item(k, 3).Value      '地域名
      If Len(sLocal) Then sLocal = sLocal & ","
      r.Item(k, 3) = sLocal & c(1, 0).Value
    End If
  Next
  Set dic = Nothing
End Sub

これでとりあえず行けると思いますが、セルへ毎回出力しているので
画面がチラついて処理が重たくなっていると思います。
最終的には 出力先範囲r と同じサイズの(十分な行数をもった)配列
を用意しておいて、処理は配列に対して行い、シートには最後に一回だけ
一括貼付けするようにすれば動作は軽く高速化できるとおもいます。

【67537】Re:出現の名称をDictionaryで出す
発言  山猿  - 10/12/11(土) 10:20 -

引用なし
パスワード
   こんな書き方もあるかもしれないです。
Sub test()
  Dim myR As Range, Mycell As Range
  Dim dic, key
  Dim k As Long
  Dim v As String
  Dim region As String

  Set myR = Range("C2" & ":" & "C" & Range("C" & Rows.Count).End(xlUp).Row)
  Set dic = CreateObject("Scripting.Dictionary")
  For Each Mycell In myR
    v = Mycell.Value
    region = Mycell.Offset(, -1).Value
    If v <> "" Then
      If dic.Exists(v) Then
        If InStr(dic(v), region) = 0 Then 'これは不要かも
          dic(v) = dic(v) & region & ","
        End If
      Else
        dic(v) = region & ","
      End If
    End If
  Next
  k = 1
  For Each key In dic.Keys
    k = k + 1
    Cells(k, "G").Value = UBound(Split(dic(key), ","))
    Cells(k, "H").Value = key
    Cells(k, "I").Value = Left(dic(key), Len(dic(key)) - 1)
  Next
  Set dic = Nothing
End Sub

【67538】Re:出現の名称をDictionaryで出す
発言  kanabun  - 10/12/11(土) 10:44 -

引用なし
パスワード
   > 配列を用意しておいて、処理は配列に対して行い、
> シートには最後に一回だけ一括貼付けする
ように書き直すと、以下の感じになると思います。

Sub Trial3() '配列利用
  Dim myR As Range
  Dim dic As Object
  Dim i As Long, n As Long, k As Long
  Dim v, sProdt As String, sLocal As String
  With Range("C:C")
    Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
    v = myR.Offset(, -1).Resize(, 2).Value2
  End With
  ReDim outv(myR.Count, 1 To 3)
  outv(0, 1) = "商品出現回数"
  outv(0, 2) = "商品名"
  outv(0, 3) = "地域名"
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(v)
    If Not IsEmpty(v(i, 2)) Then
      sProdt = v(i, 2)
      If dic.Exists(sProdt) Then
        k = dic(sProdt)  '出力行番号を取得
      Else
        n = n + 1     '新規出力行番号
        dic(sProdt) = n  '格納
        k = n
        outv(k, 2) = sProdt
      End If
      outv(k, 1) = outv(k, 1) + 1 '出現回数
      sLocal = outv(k, 3)
      If Len(sLocal) Then sLocal = sLocal & ","
      outv(k, 3) = sLocal & v(i, 1)
    End If
  Next
  Set dic = Nothing
  With Range("G1").Resize(, 3)
    .Resize(myR.Count).ClearContents
    .Resize(n + 1).Value = outv
  End With
End Sub

ただ 山葵さんのコメントにあるように、

> If InStr(dic(v), region) = 0 Then 'これは不要かも

同じ商品名で 地域名が重複して出てきたばあい
   ↓

   地域名   商品名 
   あ     AA
   あ     AA
   あ     AA
   さ     AA

商品「AA」の出現回数は 4回 で OK ですが、現状コードでは
地域名は「あ、あ、あ、さ」となってしまいます。

同じ商品で地域名はダブることはないのであればこのままでよい
のですが、重複して地域名が出現することがあるのであれば、どう
表示するのか、仕様を決めておかないといけないですね

【67539】Re:出現の名称をDictionaryで出す
回答  UO3  - 10/12/11(土) 11:07 -

引用なし
パスワード
   ▼Yoshim さん:

こんなコードでも。
同じ地域の手当てをしれて、あと、ループの中で文字列を連結するリスクを
回避しています。

Sub Sample()
 Dim wkV As Variant
 Dim myR As Range, Mycell As Range
 Dim dic As Object
 Dim dicS As Object
 Dim dicC As Object
 Dim key As Variant
 Dim v As String, a As String
 
 With Worksheets("Sheet1")  '<== 元のシート 実際のシート名に
  Set myR = .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)
 End With
 
 Set dic = CreateObject("Scripting.Dictionary")
 Set dicS = CreateObject("Scripting.Dictionary")
 Set dicC = CreateObject("Scripting.Dictionary")
 
 For Each Mycell In myR
  v = Mycell.Value
  a = Mycell.Offset(0, -1).Value
  If v <> "" Then
   If dicS.exists(v) Then
    If Not dicC.exists(v & a) Then
     dicC(a) = True
     wkV = Split(dicS(v), ",")
     ReDim Preserve wkV(0 To UBound(wkV) + 1)
     wkV(UBound(wkV)) = a
     dicS(v) = Join(wkV, ",")
    End If
   Else
    dicS(v) = a
   End If
   dic(v) = dic(v) + 1
  End If
 Next
 
 With Worksheets("Sheet2") '<== 結果表示シート 実際のシート名に
  Set myR = Intersect(.UsedRange, .UsedRange.Offset(1))
  If Not myR Is Nothing Then myR.ClearContents
  .Range("A2").Resize(dic.Count) = Application.Transpose(dic.items)
  .Range("B2").Resize(dic.Count) = Application.Transpose(dic.keys)
  .Range("C2").Resize(dic.Count) = Application.Transpose(dicS.items)
 End With
 
 Set dic = Nothing
 Set dicS = Nothing
 Set dicC = Nothing
 Set myR = Nothing
 
End Sub

【67540】Re:出現の名称をDictionaryで出す
発言  kanabun  - 10/12/11(土) 11:21 -

引用なし
パスワード
   同じ商品名で 地域が重複していたばあい、重複カットして
表示するサンプルです。

Sub Trial3b() '配列利用
  Dim myR As Range
  Dim dic As Object
  Dim i As Long, n As Long, k As Long
  Dim v, sProdt As String, sLocal As String, sL As String
  With Range("C:C")
    Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
    v = myR.Offset(, -1).Resize(, 2).Value2
  End With
  ReDim outv(myR.Count, 1 To 3)
  outv(0, 1) = "商品出現回数"
  outv(0, 2) = "商品名"
  outv(0, 3) = "地域名"
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(v)
    If Not IsEmpty(v(i, 2)) Then
      sProdt = v(i, 2)
      If dic.Exists(sProdt) Then
        k = dic(sProdt)  '出力行番号を取得
      Else
        n = n + 1   '新規出力行番号
        dic(sProdt) = n  '格納
        k = n
        outv(k, 2) = sProdt
      End If
      outv(k, 1) = outv(k, 1) + 1 '出現回数
      sLocal = outv(k, 3)
      If Len(sLocal) = 0 Then sLocal = " "
      sL = " " & v(i, 1) & " "
      If InStr(sLocal, sL) = 0 Then
        outv(k, 3) = sLocal & sL
      End If
    End If
  Next
  Set dic = Nothing
  With Range("G1").Resize(, 3)
    .Resize(myR.Count).ClearContents
    With .Resize(n + 1)
      .Value = outv
      With .Columns(3)
        .Value = Application.Substitute( _
           Application.Trim(.Cells), " ", "、")
      End With
    End With
  End With
End Sub

【67542】Re:出現の名称をDictionaryで出す
お礼  Yoshim  - 10/12/11(土) 11:52 -

引用なし
パスワード
   kanabunさん,山猿さん,UO3さん

新規投稿で書いてしまいました。失礼しました。

アドバイスありがとうございました。
またコードを書いていただきありがとうございます。

確かに地域名がダブって出てきます。
そこまで考えておりませんでした。

ただ回数のチェックとの関係で…。
地域名が今のところダブルのは仕方ないか?っと思っていますが、将来頻度が上がると・・・
地域の欄で A(4)というような表現が出来ると良いと思いますが、コード的に今のところ付いていくのが・・・出来ないかと。もう少し勉強します。
ありがとうございました。
理解が進めば、また同じ内容で次のレベルの質問をさせていただきます。

ここまで書いていましたら、重複カットのコードがいただけたようで、びっくりしています。勉強してみます、ありがとうございました。

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