Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
8388 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【33528】複雑です、、 ムーン 06/1/14(土) 13:44 質問[未読]
【33530】Re:複雑です、、 kobasan 06/1/14(土) 16:20 回答[未読]
【33552】Re:複雑です、、 ponpon 06/1/15(日) 2:13 質問[未読]
【33553】Re:複雑です、、 kobasan 06/1/15(日) 8:43 発言[未読]
【33555】Re:複雑です、、 ponpon 06/1/15(日) 11:11 お礼[未読]
【33577】Re:複雑です、、 ムーン 06/1/16(月) 9:05 お礼[未読]
【33576】Re:複雑です、、 ムーン 06/1/16(月) 9:03 お礼[未読]
【33551】Re:複雑です、、 Hirofumi 06/1/14(土) 23:35 回答[未読]
【33578】Re:複雑です、、 ムーン 06/1/16(月) 9:07 お礼[未読]
【33528】複雑です、、
質問  ムーン  - 06/1/14(土) 13:44 -
引用なし
パスワード
   はじめまして、ムーンと申します。説明も難しいのですが、ご理解頂き、解決できれば本当に幸いです。よろしくお願い致します。

　A　　B　　C　　D　　
1あ　　い　 う　ＸＸＸ　　　
2あ　　い　 う　ＸＸＸ
3あ　　い　 う　ＸＸＸ
4あ　　い　 え　ＹＹＹ
5あ　　い　 え　ＹＹＹ
6あ　　い　 え　ＹＹＹ

以下データ続きます。

上記、1行が1レコードなのですが
Ｃ１〜Ｃ３（「う」の始まりから終わり）を1レコードとしたいので
Ｄ１〜Ｄ３にある文字列を全て連結してＥ１に書き込みたい。
本当の１レコードは
　A　　B　　C　　D　　　　　　E
1あ　　い　 う　　　　　　　 ＸＸＸＸＸＸＸＸＸ
となりますが、Ｄ列の値は残していても結構です。

以下、Ｃ列の上の値と比較し、変わったところ（う→え）で上記を
繰り返して最後までいきます。

以下のように表示したいのです。

　A　　B　　C　　D　　　　　　E
1あ　　い　 う　ＸＸＸ　　　 ＸＸＸＸＸＸＸＸＸ
2あ　　い　 う　ＸＸＸ
3あ　　い　 う　ＸＸＸ
4あ　　い　 え　ＹＹＹ　　　 ＹＹＹＹＹＹＹＹＹ
5あ　　い　 え　ＹＹＹ
6あ　　い　 え　ＹＹＹ

説明べたですみませんが、どなたかお願い致します。
【33530】Re:複雑です、、
回答  kobasan  - 06/1/14(土) 16:20 -
引用なし
パスワード
   ▼ムーン さん　今日は。

これでできると思います。

Sub main()
Dim rngA As Range, r As Range
Dim Dic As Object
Dim dkey
　　'
　　Set rngA = ActiveSheet.Range("A1", Range("A65536").End(xlUp))
　　Set Dic = CreateObject("Scripting.Dictionary")
　　'
　　For Each r In rngA.Cells
　　　　dkey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
　　　　Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
　　Next
　　'
　　For Each dkey In Dic.keys()
　　For Each r In ActiveSheet.Range("A1", Range("A65536").End(xlUp))
　　　　If r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text = dkey Then
　　　　　　r.Offset(, 4) = Dic.Item(dkey)
　　　　　　Exit For
　　　　End If
　　Next
　　Next
　　'
　　Set Dic = Nothing
　　Set rngA = Nothing
End Sub
【33551】Re:複雑です、、
回答  Hirofumi  - 06/1/14(土) 23:35 -
引用なし
パスワード
   こんなでも善いかも？

Option Explicit

Public Sub Sample()

　　Dim i As Long
　　Dim lngRows As Long
　　Dim rngList As Range
　　Dim vntData As Variant
　　Dim vntResult As Variant
　　Dim lngPos As Long
　　Dim vntComp As Variant
　　Dim strProm As String
　　
　　'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
　　Set rngList = ActiveSheet.Cells(1, "A")
　　With rngList
　　　　'データ行数を取得
　　　　lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
　　　　'データが無い場合
　　　　If lngRows <= 1 And .Value = "" Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'データを配列に取得
　　　　vntData = .Offset(, 2).Resize(lngRows + 1, 2).Value
　　End With
　　
　　'画面更新を停止
　　Application.ScreenUpdating = False
　　
　　'比較用変数に比較値を代入
　　vntComp = vntData(1, 1)
　　'結果用変数にD列の値を代入
　　vntResult = CStr(vntData(1, 2))
　　
　　For i = 2 To lngRows + 1
　　　　'もし、比較用変数と比較値が違ったら
　　　　If vntData(i, 1) <> vntComp Then
　　　　　　'結果を出力
　　　　　　rngList.Offset(lngPos, 4).Value = vntResult
　　　　　　'位置を保存
　　　　　　lngPos = i - 1
　　　　　　'比較用変数の比較値を更新
　　　　　　vntComp = vntData(i, 1)
　　　　　　'結果用変数にD列の値を代入
　　　　　　vntResult = CStr(vntData(i, 2))
　　　　Else
　　　　　　'結果用変数にD列の値を連結
　　　　　　vntResult = vntResult & CStr(vntData(i, 2))
　　　　End If
　　Next i
　　
　　strProm = "処理が完了しました"
　　
Wayout:
　　
　　'画面更新を再開
　　Application.ScreenUpdating = True
　　
　　Set rngList = Nothing
　　
　　MsgBox strProm, vbInformation
　　
End Sub
【33552】Re:複雑です、、
質問  ponpon  - 06/1/15(日) 2:13 -
引用なし
パスワード
   ムーン さん、kobasanさん、Hirohumiさん　こんばんは。

Dictionaryを使えるようになろうと、kobasanさんのを参考に
勉強がてらに作ってみたのですが・・・
私が作ると、以下のようになります。

Sub test()
　　Dim myR As Range, r As Range
　　Dim Dic As Object
　　Dim myKey
　　
　　With Sheets("Sheet1")
　　　 Set myR = ActiveSheet.Range("A1", Range("A65536").End(xlUp))
　　　 Set Dic = CreateObject("Scripting.Dictionary")
　　
　　　 Application.ScreenUpdating = False
　　　 For Each r In myR
　　　　　 myKey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
　　　　　 If Dic.Exists(myKey) Then
　　　　　　　Dic(myKey) = Dic(myKey) + r.Offset(, 3).Text
　　　　　 Else
　　　　　　　Dic.Add myKey, r.Offset(0, 3).Text
　　　　　　　'Dic(myKey) = r.Offset(0, 3).Text
　　　　　 End If
　　　 Next
　　　 For Each myKey In Dic.keys()
　　　　 For Each r In myR
　　　　　 If r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text = myKey Then
　　　　　　　r.Offset(, 4) = Dic(myKey)
　　　　　　　Exit For
　　　　　 End If
　　　　Next
　　　Next
　End With
　　　Application.ScreenUpdating = True
　　
　　　Set Dic = Nothing
　　　Set myR = Nothing
End Sub

そこで、

　　　 For Each r In myR
　　　　　 myKey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
　　　　　 If Dic.Exists(myKey) Then
　　　　　　　Dic(myKey) = Dic(myKey) + r.Offset(, 3).Text
　　　　　 Else
　　　　　　　Dic.Add myKey, r.Offset(0, 3).Text
　　　　　　　'Dic(myKey) = r.Offset(0, 3).Text
　　　　　 End If
　　　 Next
と

>　　For Each r In rngA.Cells
>　　　　dkey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
>　　　　Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
>　　Next
は、
同じ事をしているのだと思うのですが、kobasanさんのコードが
理解できません。
Dictionary自体をよく理解していないので、とんちんかんな質問なら
申し訳ないのですが、教えていただけますか？

　>Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
この段階で、　　　　~~~~~~~~~~~~~~~~は、まだ定義されていないので
エラーになるような気がするのですが(もちろんエラーにはなりませんが）。
Range("A1").Value = Range("A1").Value ＋ 1の様な場合は、
初めは、Range("A1").Value がNULL値(?)=0または、""と考えられるのですが・・・
　>Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
の場合は、まだ辞書(Dic)に何も登録していないのに、同じように考えて
いいのでしょうか？
　宜しくお願いします。
【33553】Re:複雑です、、
発言  kobasan  - 06/1/15(日) 8:43 -
引用なし
パスワード
   ponpon さん、おはようございます。
ムーン さん、Hirohumiさん、おはようございます。

>Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
>この段階で、　　　　~~~~~~~~~~~~~~~~は、まだ定義されていないので
>エラーになるような気がするのですが(もちろんエラーにはなりませんが）。
>Range("A1").Value = Range("A1").Value ＋ 1の様な場合は、
>初めは、Range("A1").Value がNULL値(?)=0または、""と考えられるのですが・・・
>Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
>の場合は、まだ辞書(Dic)に何も登録していないのに、同じように考えて
>いいのでしょうか？

私も、この質問箱で、このやり方を勉強させてもらいました。
このやり方は、一石二鳥というか非常においしい話で、

dkeyがkeyに登録されてなかったら、keyに追加登録し、Itemも登録してくれる

という動きをしているわけです。
つまり、
Dic.Add myKey, r.Offset(0, 3).Text
もやってくれているわけです。

この動きを利用すると、重複しているデータを簡単に集計したり、
今回のように、同じkeyのデータを簡単にまとめることができます。
こんな説明でいいでしょうか。

ついでに、この勉強は「とまとさん」の投稿で勉強させてもらいました。
「とまと」で検索してみてください。
【33555】Re:複雑です、、
お礼  ponpon  - 06/1/15(日) 11:11 -
引用なし
パスワード
   おはようございます。

#28366ですね？　しっかりROMしてましたが、この時は、まだ意味がわかって
いませんでした。

>このやり方は、一石二鳥というか非常においしい話で、
>dkeyがkeyに登録されてなかったら、keyに追加登録し、Itemも登録してくれる
>という動きをしているわけです。
>つまり、
>Dic.Add myKey, r.Offset(0, 3).Text
>もやってくれているわけです。

動きは、上記の通りだと思ったのですが、不思議に感じたものですから・・
Dictionaryのヘルプは単純なものしか説明がないので・・・・
まっ　そういうものだと思い　これからは、使えるようになりたいと思います。
ありがとうございました。

ムーンさん横からすみませんでした。
【33576】Re:複雑です、、
お礼  ムーン  - 06/1/16(月) 9:03 -
引用なし
パスワード
   ▼kobasan さん：
>▼ムーン さん　今日は。
>
>これでできると思います。
>
>Sub main()
>Dim rngA As Range, r As Range
>Dim Dic As Object
>Dim dkey
>　　'
>　　Set rngA = ActiveSheet.Range("A1", Range("A65536").End(xlUp))
>　　Set Dic = CreateObject("Scripting.Dictionary")
>　　'
>　　For Each r In rngA.Cells
>　　　　dkey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
>　　　　Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
>　　Next
>　　'
>　　For Each dkey In Dic.keys()
>　　For Each r In ActiveSheet.Range("A1", Range("A65536").End(xlUp))
>　　　　If r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text = dkey Then
>　　　　　　r.Offset(, 4) = Dic.Item(dkey)
>　　　　　　Exit For
>　　　　End If
>　　Next
>　　Next
>　　'
>　　Set Dic = Nothing
>　　Set rngA = Nothing
>End Sub

kobasan、ありがとうございます。
変身遅くなりました、試してみます。
【33577】Re:複雑です、、
お礼  ムーン  - 06/1/16(月) 9:05 -
引用なし
パスワード
   ▼ponpon さん：
>おはようございます。
>
>#28366ですね？　しっかりROMしてましたが、この時は、まだ意味がわかって
>いませんでした。
>
>>このやり方は、一石二鳥というか非常においしい話で、
>>dkeyがkeyに登録されてなかったら、keyに追加登録し、Itemも登録してくれる
>>という動きをしているわけです。
>>つまり、
>>Dic.Add myKey, r.Offset(0, 3).Text
>>もやってくれているわけです。
>
>動きは、上記の通りだと思ったのですが、不思議に感じたものですから・・
>Dictionaryのヘルプは単純なものしか説明がないので・・・・
>まっ　そういうものだと思い　これからは、使えるようになりたいと思います。
>ありがとうございました。
>
>ムーンさん横からすみませんでした。

kobasan,ponponsan、お二方に感謝しております。本当にありがとう
御座いました。
【33578】Re:複雑です、、
お礼  ムーン  - 06/1/16(月) 9:07 -
引用なし
パスワード
   ▼Hirofumi さん：
>こんなでも善いかも？
>
>Option Explicit
>
>Public Sub Sample()
>
>　　Dim i As Long
>　　Dim lngRows As Long
>　　Dim rngList As Range
>　　Dim vntData As Variant
>　　Dim vntResult As Variant
>　　Dim lngPos As Long
>　　Dim vntComp As Variant
>　　Dim strProm As String
>　　
>　　'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
>　　Set rngList = ActiveSheet.Cells(1, "A")
>　　With rngList
>　　　　'データ行数を取得
>　　　　lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
>　　　　'データが無い場合
>　　　　If lngRows <= 1 And .Value = "" Then
>　　　　　　strProm = "データが有りません"
>　　　　　　GoTo Wayout
>　　　　End If
>　　　　'データを配列に取得
>　　　　vntData = .Offset(, 2).Resize(lngRows + 1, 2).Value
>　　End With
>　　
>　　'画面更新を停止
>　　Application.ScreenUpdating = False
>　　
>　　'比較用変数に比較値を代入
>　　vntComp = vntData(1, 1)
>　　'結果用変数にD列の値を代入
>　　vntResult = CStr(vntData(1, 2))
>　　
>　　For i = 2 To lngRows + 1
>　　　　'もし、比較用変数と比較値が違ったら
>　　　　If vntData(i, 1) <> vntComp Then
>　　　　　　'結果を出力
>　　　　　　rngList.Offset(lngPos, 4).Value = vntResult
>　　　　　　'位置を保存
>　　　　　　lngPos = i - 1
>　　　　　　'比較用変数の比較値を更新
>　　　　　　vntComp = vntData(i, 1)
>　　　　　　'結果用変数にD列の値を代入
>　　　　　　vntResult = CStr(vntData(i, 2))
>　　　　Else
>　　　　　　'結果用変数にD列の値を連結
>　　　　　　vntResult = vntResult & CStr(vntData(i, 2))
>　　　　End If
>　　Next i
>　　
>　　strProm = "処理が完了しました"
>　　
>Wayout:
>　　
>　　'画面更新を再開
>　　Application.ScreenUpdating = True
>　　
>　　Set rngList = Nothing
>　　
>　　MsgBox strProm, vbInformation
>　　
>End Sub

hirofumiさん、ありがとうございました。
様々なパターンためさせて頂きます。
遅くなりました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
8388 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free