vbs データ登録用にcsvを編集

質問

vbsで以下のように編集したいです。
よろしければコードのご教示宜しくお願い致します。
<編集前>
　　　A　　　　　B　　　　　　C　　　　　D
1　#氏名　　　メアド1　　　メアド2　　メアド3...........メアド10
2　田中太郎　aaa@aaa.jp　
3　田中太郎　bbb@bbb.jp　ccc@ccc.jp
4　田中太郎　aaa@aaa.jp　　　　　　　ddd@ddd.jp

<編集後>
　　　A　　　　　B　　　　　　C　　　　　D　　　　　E
1　#氏名　　　メアド1　　　メアド2　　　メアド3　　メアド4........メアド10
2　田中太郎　aaa@aaa.jp　bbb@bbb.jp　ccc@ccc.jp　ddd@ddd.jp

<編集内容>
・氏名をキーに同一の氏名があった場合に、一行にメアドをまとめる。
・一行に表示するメアド数の上限は、10個(メアド10)として、それ以上は削除
・メアドが被った場合は、置換する。(B列のaaa@aaa.jpを指す)
・メアド10まで埋まらなかった場合は、メアド10(K列)まで","(カンマ)を一つのセルごとに出力する。

説明が下手ですみません。
条件不足等ございましたらお知らせください。

回答No.2

watabe007 · ベストアンサー

一行目の項目名を忘れていました。
Option Explicit
Dim a, cr, cv, f, i, j, k, n, wa, so, x, buf, myDic, d, str, v, v2(10), L
Set so = CreateObject("Scripting.FileSystemObject")
Set myDic = CreateObject("Scripting.Dictionary")
Set wa = WScript.Arguments
For i = 0 to wa.Count - 1
If LCase(so.GetExtensionName(wa(i))) = "csv" Then
f = so.GetParentFolderName(wa(i))
n = so.GetBaseName(wa(i))
With so.OpenTextFile(wa(i), 1)
' .SkipLine
buf = .ReadAll
.Close
End With
buf = Split(buf, vbCrLf)
For j = 1 to UBound(buf)
a = Split(buf(j), ",")
If UBound(a) > 0 Then
If Not myDic.Exists(a(0)) Then myDic.Add a(0), Empty
For k = 1 to UBound(a)
If myDic(a(0)) = "" Then
myDic(a(0)) = a(k)
Else
If a(k) <> "" and InStr(myDic(a(0)), a(k)) = 0 Then
myDic(a(0))= myDic(a(0)) & "," & a(k)
End if
End If
NeXt
End If
Next
Set cr = so.OpenTextFile(f & "\" & n & "(Result).csv", 2, True)
cr.WriteLine buf(0)
For Each d In myDic.keys
str = myDic(d) & String(9, ",")
v = Split(str, ",")
v2(0) = d
For L = 1 to 10
v2(L) = v(L-1)
Next
cr.WriteLine Join(v2, ",")
Next
cr.Close
myDic.RemoveAll
End If
Next
Set cv = Nothing
Set cr = Nothing
Set wa = Nothing
Set so = Nothing
Set myDic = Nothing
MsgBox("Finished!")

お礼

ご回答ありがとうございました。
自身で整理し理解を深めようと思います。

補足

ご回答ありがとうございます。
差し支えなければ、一行一行のコードの説明を加えていただけないでしょうか。
難しいようであれば結構です。

回答No.1

watabe007

レスがつかないですね
Prome_Lin さんのコードを無断使用しました。
お試しください。
Option Explicit
Dim a, cr, cv, f, i, j, k, n, wa, so, x, buf, myDic, d, str, v, v2(10), L
Set so = CreateObject("Scripting.FileSystemObject")
Set myDic = CreateObject("Scripting.Dictionary")
Set wa = WScript.Arguments
For i = 0 to wa.Count - 1
If LCase(so.GetExtensionName(wa(i))) = "csv" Then
f = so.GetParentFolderName(wa(i))
n = so.GetBaseName(wa(i))
With so.OpenTextFile(wa(i), 1)
.SkipLine
buf = .ReadAll
.Close
End With
buf = Split(buf, vbCrLf)
For j = 0 to UBound(buf)
a = Split(buf(j), ",")
If UBound(a) > 0 Then
If Not myDic.Exists(a(0)) Then myDic.Add a(0), Empty
For k = 1 to UBound(a)
If myDic(a(0)) = "" Then
myDic(a(0)) = a(k)
Else
If a(k) <> "" and InStr(myDic(a(0)), a(k)) = 0 Then
myDic(a(0))= myDic(a(0)) & "," & a(k)
End if
End If
NeXt
End If
Next
Set cr = so.OpenTextFile(f & "\" & n & "(Result).csv", 2, True)
For Each d In myDic.keys
str = myDic(d) & String(9, ",")
v = Split(str, ",")
v2(0) = d
For L = 1 to 10
v2(L) = v(L-1)
Next
cr.WriteLine Join(v2, ",")
Next
cr.Close
myDic.RemoveAll
End If
Next
Set cv = Nothing
Set cr = Nothing
Set wa = Nothing
Set so = Nothing
Set myDic = Nothing
MsgBox("Finished!")