Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

34291 / 76738

←次へ　｜　前へ→


	【47657】Re:二つのデータを見比べて、新リストを作成

ichinose - 07/3/17(土) 19:01 -


	引用なし

	パスワード

こんばんは。
データの種類が↓のように　数字-名前
というパターンなら、

>
>A列　　　　　　　B列
>(参加予定者）　　(実際の参会者）
>01-Aさん　　　　　01-Aさん
>02-Bさん　　　　　03-Cさん
>03-Cさん　　　　　03-Cさん
>04-Dさん　　　　　06-Fさん　
>05-Eさん　　　　　11-Jさん（突然参加者）
>06-Fさん　　　　　11-Jさん（突然参加者）
>07-Gさん　　　　　13-Lさん（突然参加者）

標準モジュールに
'===============================================
Sub test()
　　Dim marray As Variant
　　Dim rng As Range
　　Dim crng As Range
　　Dim ans As Variant
　　Dim dkey As Variant
　　Dim dat As Variant
　　Dim num As Long
　　Dim g0 As Long
　　Dim g1 As Long
　　Dim g2 As Long
　　If Cells(Rows.Count, "b").End(xlUp).Row > 1 Then
　　　 With CreateObject("scripting.dictionary")
　　　　　ans = Application.Transpose(Range("b2", Cells(Rows.Count, "b").End(xlUp)).Value)
　　　　　For g0 = LBound(ans) To UBound(ans)
　　　　　　 dkey = Val(Split(ans(g0), "-")(0))
　　　　　　 If .Exists(dkey) Then
　　　　　　　　marray = .Item(dkey)
　　　　　　　　marray(1) = marray(1) + 1
　　　　　　　　.Item(dkey) = marray
　　　　　　 Else
　　　　　　　　.Add dkey, Array(ans(g0), 1)
　　　　　　　　End If
　　　　　　 Next
　　　　　Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
　　　　　If rng.Row > 1 Then
　　　　　　 For Each crng In rng
　　　　　　　　dkey = Val(Split(crng.Value, "-")(0))
　　　　　　　　If Not .Exists(dkey) Then
　　　　　　　　　 .Add dkey, Array(crng.Value, 1)
　　　　　　　　　 End If
　　　　　　　　Next
　　　　　　 End If
　　　　　g0 = LBound(.Keys)
　　　　　g1 = 2
　　　　　Do While g0 <= UBound(.Keys)
　　　　　　 dat = .Item(Application.Small(.Keys, g0 + 1))(0)
　　　　　　 num = .Item(Application.Small(.Keys, g0 + 1))(1)
　　　　　　 For g2 = 1 To num
　　　　　　　　Cells(g1, 3).Value = dat
　　　　　　　　g1 = g1 + 1
　　　　　　　　Next
　　　　　　 g0 = g0 + 1
　　　　　　 Loop
　　　　　End With
　　　 End If
End Sub

0 hits

▼

【47625】二つのデータを見比べて、新リストを作成 Mia 07/3/16(金) 19:31