[[20130517100839]]　『Dictionaryについて』（ろっくん）　ページの最後に飛ぶ

『Dictionaryについて』（ろっくん）

 下記のようなテキストデータをDictionaryに登録させていきたいのですが、
 カンマ区切りの1～3フィールドが同じだったら4フィールド目が小さいものだけを
 登録させたいです。
 4000,25,1,23
 4000,25,1,38
 4000,26,2,15
 4000,26,3,5
 4000,26,3,17

 上記であれば
 4000,25,1,23
 4000,26,2,15
 4000,26,3,5
 の3つがあればよいのですが、方法がよくわかりません。

 DictionaryObjectを使用すれば・・というイメージはあるのですが、
 どのようにすればできるのでしょうか？
 WinXP Excel2003のVBAを使用しています。

 とりあえず。Ａ列に値があって、確認用に結果をＢ列に吐き出している。

 Sub Sample()
    Dim dic As Object
    Dim c As Range
    Dim dKey As String
    Dim w As Variant
    Dim n As Variant

    Set dic = CreateObject("Scripting.Dictionary")

    For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
        w = Split(c.Value, ",")
        If UBound(w) = 3 Then   '４項目データではない場合は無視
            n = w(3)
            ReDim Preserve w(LBound(w) To UBound(w) - 1)
            dKey = Join(w, ",")
            If Not dic.exists(dKey) Then
                dic(dKey) = dKey & "," & n
            Else
                If n < Split(dic(dKey), ",")(3) Then dic(dKey) = dKey & "," & n
            End If
        End If
    Next

    '確認用
    Columns("B").ClearContents
    Range("B1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)

 End Sub

 (ぶらっと)

 あるいは、.txtファイルからの読み込み？？
 Sub sample()
    Dim fn As String, tbl, v, dic, res, y
    Dim i As Long, ii As Long, n As Long, ref As Long, k As String
    fn = "C:\test.txt" 'ファイルパス
    tbl = CreateObject("scripting.filesystemobject").OpenTextFile(fn).ReadAll
    v = Split(tbl, vbCrLf)
    Set dic = CreateObject("scripting.dictionary")
    For i = 0 To UBound(v)
        ref = InStr(Mid$(v(i), InStr(v(i), ",") + 1), ",") + InStr(v(i), ",") + 1
        k = Left$(v(i), ref + InStr(Mid$(v(i), ref), ",") - 2)
        If Not dic.exists(k) Then
           dic(k) = dic(k) + 1: ii = ii + 1
        End If
    Next i
    ReDim res(1 To ii, 1 To 1)
    For Each y In dic.keys
        res(n + 1, 1) = y: n = n + 1
    Next
    With Sheets(1).Range("A1").Resize(dic.Count)
        .CurrentRegion.Clear
        .Value = res
    End With
 End Sub
(Jera)

 こんな感じて・・・　C列に結果表示
 Sub test()
   Dim i&, j&, v, S$, D As Object
      Set D = CreateObject("scripting.dictionary")
      For i = 1 To Cells(Rows.Count, "a").End(xlUp).Row
         On Error Resume Next
            v = Split(Cells(i, 1).Value, ",")
            S = v(0) & "," & v(1) & "," & v(2)
            If Not D.exists(S) Then
               D(S) = v(3)
            Else
               If CLng(D(S)) > CLng(v(3)) Then D(S) = v(3)
            End If
         On Error GoTo 0
      Next
      '展開 C列
      For Each v In D.keys
         j = j + 1
         Cells(j, "c").Value = v & "," & D(v)
      Next
      Set D = Nothing
 End Sub
 (暇人)

 ぶらっとさん、Jeraさん、暇人さん

 早々にご回答いただきましてありがとうございます。
 実際はテキストファイルからの読み込みです。
 情報が不足しており申し訳ありませんでした。

 早速試してみます！

 （ろっくん）

 うぁー、めっちゃ勘違い＾０＾；小さい方でしたね！
Sub sample()
    Dim fn As String, v, dic, res, y, t As Long
    Dim i As Long, ii As Long, n As Long, ref As Long, k As String
    fn = "C:\test.txt" 'ファイルパス
    v = Split(CreateObject("scripting.filesystemobject").OpenTextFile(fn).ReadAll, vbCrLf)
    Set dic = CreateObject("scripting.dictionary")
    For i = 0 To UBound(v)
        ref = InStr(Mid$(v(i), InStr(v(i), ",") + 1), ",") + InStr(v(i), ",") + 1
        k = Left(v(i), ref + InStr(Mid$(v(i), ref), ",") - 2)
        t = Split(v(i), ",")(3)
        If Not dic.exists(k) Then
            dic.Add k, t: ii = ii + 1
        ElseIf t < dic(k) Then
            dic(k) = t
        End If
    Next i
    ReDim res(1 To ii, 1 To 1)
    For Each y In dic.keys
        res(n + 1, 1) = y & "," & dic(y): n = n + 1
    Next
    With Sheets(1).Range("A1").Resize(dic.Count)
        .CurrentRegion.Clear
        .Value = res
    End With
End Sub
(Jera)

 Jeraさん

 Jeraさんのコードを使用させていただこうと思いますが、
 出力結果が1フィールド足りません。
 どのように改良したらいいでしょうか・・？

 （ろっくん）

 なんか、どこかで書いたようなコードがあるけど...

 Option Explicit

 Sub test()
    Dim fn As String, x, e, y, temp As String, delim As String
    delim = ","   '<- 区切り文字
    fn = "c:\z-test1\aaa.txt"  '<- ファイルパス
    x = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll, vbCrLf)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each e In x
            y = Split(e, delim)
            If UBound(y) > 2 Then
                temp = Join(Array(y(0), y(1), y(2)), Chr(2))
                If Not .exists(temp) Then
                    .Item(temp) = y
                Else
                    If Val(y(3)) < Val(.Item(temp)(3)) Then .Item(temp) = y
                End If
            End If
        Next
        MsgBox .Count
        Cells(1).Resize(.Count, 4).Value = Application.Transpose(Application.Transpose(.items))
    End With
End Sub
(seiya)

 >出力結果が1フィールド足りません。
 ・・・何でだろ・・・？ちょっと考えてみます。
 私のコードの7割以上はseiyaさんから学んだ(盗んだ)ものですので
 (特にopentextfileは実務でも大変重宝しています)
 そちらも試してみて下さいね。
(Jera)

 あ、もしかして最初にUPしたほう動かしてます？
 一番最初にUPしたものはUbound(v)-1になっていたので、修正したんです。(結局間違ってたんですが)
 そちらは捨てて下さいね。一応確認。
(Jera)

コメント返信：

[ 一覧(最新更新順) ]

[[20130517100839]] 『Dictionaryについて』（ろっくん） ページの最後に飛ぶ

[[20130517100839]]　『Dictionaryについて』（ろっくん）　ページの最後に飛ぶ