[[20110906101143]]　『CSV出力について』（九九）　ページの最後に飛ぶ

『CSV出力について』（九九）
Excel2003、WindowsXP

マクロにて以下の条件でCSV形式で出力可能でしょうか？

A列にある同一データを最大5行分（1行はA列～C列まで）抜き出し、合計10行集まったらCSVファイルに出力し、

出力した行は削除（5行分以上有った場合は、6行目以降は削除せず）。

かつ、抜き出したデータと同一のデータは再度出力せず、シートの最初から最後までこの動作を繰り返し、

出力するCSVファイル名は0000から作成された順に0001、0002、・・・と自動で作成。

宜しくお願いします。

 要件を誤解しているかもしれないけど・・・

 Sub Sample()
    Dim idCsv As Long
    Dim z As Long, x As Long, i As Long
    Dim myPath As String
    Dim sh As Worksheet

    Application.ScreenUpdating = False
    myPath = "C:\TEST\"       '★保存フォルダ。実際のものに。
    Set sh = Sheets("Sheet1") '元ブックのシート
    z = sh.Range("A" & Rows.Count).End(xlUp).Row \ 5
    Workbooks.Add
    If z = 0 Then z = 1
    For i = 1 To z
        x = (i - 1) * 5 + 1
        Cells.Clear
        Range("A1:C5").Value = sh.Range("A" & x & ":C" & x + 4).Value
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=myPath & Format(idCsv, "0000") & ".csv", _
                                        FileFormat:=xlCSV, CreateBackup:=False
        Application.DisplayAlerts = True
        idCsv = idCsv + 1
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Close saveChanges:=False
    Application.DisplayAlerts = True
    sh.Rows(1).Resize(z * 5).Delete
    Application.ScreenUpdating = True
    MsgBox "処理が完了しました"

 End Sub

 (ぶらっと)

回答ありがとうございます。

実行したところ、CSVのファイルは出力されるのですが、データの方は入っていませんでした。

また、A列に同一データが5行以上ある場合も実行後、全て削除されておりました。

近い動作はしているようなので、私の方でも色々試してみたいと思います。

ありがとうございました。

（九九）

 > A列にある同一データを最大5行分（1行はA列～C列まで）抜き出し、合計10行集まったらCSVファイルに出力し、

 ここを、すっかり読み飛ばしていた。
 アップしたコードは、完全に的外れ。

 ★ところで、【同一データ】とは、何を基準に判断すればいいのかな？
　 A列,B列,C列の値がそれぞれ全く同じ値を持つ行が同一データ？
　 たとえば10行目に aaa,bbb,ccc 20行目にも aaa,bbb,ccc このとき 10行目と20行目が同一データ？

 (ぶらっと)

A列にIPが設定されており、B列とC列はバラバラの数字です。

A列で同一のIPがあったら、その行のB列とC列を格納する、といった感じです。

A列のIPは同一のものが1つ以上あり、正確な数は不明ですが、同一IPが複数ある場合がある為、

そのうち同一IPの情報を5件まで抜き出したいという事です。

説明が下手で申し訳ないです。

（九九）

 わぁ、今、Ａ，Ｂ，Ｃ連結値で同一チェックしたものを書き上げてアップしようとしたところ。
はい、書きなおします。

 (ぶらっと)

 さぁ、どうだろうか。まだ要件を誤解しているか。
絶対に文句を言われそうなところがある。出力のＣＳＶ，かならずしも、元シートに現れた上のほうから
まとめているわけじゃない。
ここも、元シート順ということであれば、ちょっと大変だなぁ。処理をがらっとかえる必要がでてくるかも。

 追記）↑　と書いた後、やっぱり誤解してるのかなぁと。
　　　ＣＳＶには重複分を１行にして持っていってるけど、きっとそうじゃなく、重複行を
　　　そのまま持っていくんだろうなぁ。まぁ、とりあえず試してみて。

 Sub Sample2()
    Dim mySh As Worksheet
    Dim wkSh As Worksheet
    Dim z As Long, k As Long
    Dim c As Range

    Application.ScreenUpdating = False

    Set mySh = Sheets("Sheet1")                       '元シート
    mySh.Copy before:=Sheets(Sheets.Count)              '元シートを作業用にコピー
    Set wkSh = ActiveSheet

    With wkSh
        z = .Range("A" & .Rows.Count).End(xlUp).Row
        'ユニークキー　Ａ列を直接使ってもいいけど、
        '将来、要件変更で複数列のコンバインが必要になった時の
        '対応を容易にするためにＤ列を使う。
        .Columns("D").Value = .Columns("A").Value

        With .Range("F1:F" & z)                       '元の並び順
            .Cells(1).Value = 1
            .Cells.DataSeries
        End With

        'A , B, C列の連結値で並び替え
        .Cells.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlNo

        With .Range("E1:E" & z)                       '重複カウント
            .Formula = "=COUNTIF(D$1:D1,D1)"
            .Value = .Value
        End With

        'フィルター処理用にタイトル行セット
        .Rows("1:1").Insert Shift:=xlDown
        .Range("A1:F1").Value = Array("A", "B", "C", "D", "E", "F")
        .Range("G1").Value = .Range("E1").Value       'フィルタ用タイトル
        .Range("G2").Value = "'=2"                    'フィルタリング値
        'フィルタリング実行
        .Columns("A:E").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("G1:G2"), _
                                                        CopyToRange:=.Range("H1"), Unique:=False

        Call GenCsv(wkSh)    '抽出結果をもとにＣＳＶ作成処理

        '元シートメンテナンス
        For Each c In .Range("A2").Resize(z)
            If c.Offset(, 4).Value >= 6 Then
                c.Offset(, 4).Value = "YES"
            Else
                If c.Offset(, 3).Value <> c.Offset(1, 3).Value Then
                    If c.Offset(, 4).Value = 1 Then
                        c.Offset(, 4).Value = "YES"
                    End If
                End If
            End If
        Next

        '元シートの並び順に並び替え
        .Cells.Sort Key1:=Range("F1"), Order1:=xlAscending, Header:=xlYes

        mySh.Cells.ClearContents
        mySh.Range("A1:C1").Value = .Range("A1:C1").Value
        .Range("G2").Value = "YES"                    'フィルタリング値
        .Columns("A:E").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("G1:G2"), _
                                                CopyToRange:=mySh.Range("A1:C1"), Unique:=False
        mySh.Rows(1).Delete

        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True

    End With

    Application.ScreenUpdating = True

    MsgBox "処理が完了しました"

 End Sub

 Private Sub GenCsv(sh As Worksheet)
    Dim idCsv As Long
    Dim z As Long, x As Long, i As Long
    Dim myPath As String

    myPath = "C:\TEST\"       '★保存フォルダ。実際のものに。
    z = (sh.Range("H" & Rows.Count).End(xlUp).Row - 1) \ 5
    Workbooks.Add
    If z = 0 Then z = 1
    For i = 1 To z
        x = (i - 1) * 5 + 2
        Cells.Clear
        Range("A1:C5").Value = sh.Range("H" & x & ":J" & x + 4).Value
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=myPath & Format(idCsv, "0000") & ".csv", _
                                        FileFormat:=xlCSV, CreateBackup:=False
        Application.DisplayAlerts = True
        idCsv = idCsv + 1
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Close saveChanges:=False
    Application.DisplayAlerts = True

 End Sub

 (ぶらっと)

ご推察のとおりです。

CSVには重複行をそのまま（5行あったらそのまま5行を移す）、のつもりでした。

わざわざ作成して頂いたのに申し訳ないです。

また、上記のマクロを実行したところ、

並べ替えの参照が正しくありません。参照が並べ替えるデータ内にあることと、

[最優先されるキー]ボックスが空白でないことを確認してください。

と、エラー文が表示されました。

（九九）

 とりあえず書きなおしてみた。今までのものはすべて捨てて以下。
でも、まだ、誤解してるところとか、ありそうだなぁ。
もう並び替えは使わないんだけど、

 >並べ替えの参照が正しくありません。参照が並べ替えるデータ内にあることと、 
 >[最優先されるキー]ボックスが空白でないことを確認してください。 
 >と、エラー文が表示されました。

 こちらでは（実行結果は別にして）エラーはでていない。ということは、こちらで想定している
元シートのレイアウトが違うのかな？
こちらの理解は、１行目からデータ。

 あぁ、それと、コードは標準モジュールに。（念のため）

 Sub Sample3()
    Dim dicX As Object    '残すデータ
    Dim k As Long         '残すデータコントロール
    Dim dicCSV As Object   'CSV用（データ）
    Dim dicCnt As Object   'CSV用（件数）
    Dim z As Long          'CSVコントロール
    Dim dKey As Variant
    Dim c As Range
    Dim v As Variant
    Dim wkSh As Worksheet

    Application.ScreenUpdating = False

    Set dicX = CreateObject("Scripting.Dictionary")
    Set dicCSV = CreateObject("Scripting.Dictionary")
    Set dicCnt = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")     '元シート
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            v = Array(c.Value, c.Offset(, 1).Value, c.Offset(, 2).Value)
            If WorksheetFunction.CountIf(.Columns("A"), c.Value) = 1 Then
                k = k + 1
                dicX(k) = v
            Else
                If Not dicCnt.exists(c.Value) Then
                    dicCnt(c.Value) = 1
                    z = z + 1
                    dicCSV(z) = v
                Else
                    If dicCnt(c.Value) < 5 Then
                        dicCnt(c.Value) = dicCnt(c.Value) + 1
                        z = z + 1
                        dicCSV(z) = v
                    Else
                        k = k + 1
                        dicX(k) = v
                    End If
                End If
            End If
        Next
        .Cells.ClearContents
        .Range("A1:C1").Resize(dicX.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicX.items))
    End With

    Sheets.Add
    Set wkSh = ActiveSheet
    wkSh.Range("A1:C1").Resize(dicCSV.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicCSV.items))

    Call GenCsv(wkSh)

    Application.DisplayAlerts = False
    wkSh.Delete
    Application.DisplayAlerts = True

    Set dicX = Nothing
    Set dicCSV = Nothing
    Set dicCnt = Nothing
    Set wkSh = Nothing

    Application.ScreenUpdating = True

    MsgBox "処理が完了しました"

 End Sub

 Private Sub GenCsv(sh As Worksheet)
    Dim idCsv As Long
    Dim z As Long, x As Long, i As Long
    Dim myPath As String

    myPath = "C:\TEST\"       '★保存フォルダ。実際のものに。
    z = (sh.Range("A" & Rows.Count).End(xlUp).Row - 1) \ 5
    Workbooks.Add
    If z = 0 Then z = 1
    For i = 1 To z
        x = (i - 1) * 5 + 1
        Cells.Clear
        Range("A1:C5").Value = sh.Range("A" & x & ":C" & x + 4).Value
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=myPath & Format(idCsv, "0000") & ".csv", _
                                        FileFormat:=xlCSV, CreateBackup:=False
        Application.DisplayAlerts = True
        idCsv = idCsv + 1
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Close saveChanges:=False
    Application.DisplayAlerts = True

 End Sub

 (ぶらっと)

 別案で

 Sub test()
Dim i As Long, ii As Long, rng As Range, r As Range, txt As String, x
Dim a, n As Long, temp, t As Long
Set rng = Range("a1").CurrentRegion.Resize(, 3)
ReDim a(1 To rng.Rows.Count, 1 To 2)
With CreateObject("Scripting.Dictionary")
    For Each r In rng.Columns(1).Cells
        If Not .exists(r.Value) Then
            n = n + 1: .Item(r.Value) = n
        End If
        x = .Item(r.Value)
        If a(x, 2) < 5 Then
            a(x, 1) = a(x, 1) & _
            vbCrLf & Join$(Application.Transpose(Application _
            .Transpose(r.Resize(, 3))), ",")
            a(x, 2) = a(x, 2) + 1
            r.ClearContents
        End If
    Next
End With
rng.Columns(1).SpecialCells(4).EntireRow.Delete
For i = 1 To n
    ii = 1
    txt = Mid$(a(i, 1), 3)
    If i + ii <= n Then
        temp = a(i, 2) + a(i + ii, 2)
    Else
        temp = 0
    End If
    Do While temp <= 10
        txt = txt & a(i + ii, 1)
        ii = ii + 1
        If ii > n Then Exit Do
        temp = temp + a(i + ii, 2)
    Loop
    t = t + 1
    Open ThisWorkbook.Path & "\" & Format$(t, "00000") & ".csv" For Output As #1
        Print #1, txt
    Close #1
    txt = ""
    i = i + ii - 1
Next
End Sub
(seiya)

 アップしたコードをつらつら眺めていたら出力を５行ごとにしてた。

合計10行集まったらCSVファイルに出力し、

 なので、１０行単位だよね。
 ＣＳＶかどうかの振り分けのところのコードが、あまりにも無様なので、それもあわせて
 後ほど再々アップよてい。

 (ぶらっと)

 これで大丈夫だと思う。

 Sub Sample4()
    Dim dicX As Object    '残すデータ
    Dim k As Long         '残すデータコントロール
    Dim dicCSV As Object   'CSV用（データ）
    Dim dicCnt As Object   'CSV用（件数）
    Dim z As Long          'CSVコントロール
    Dim dKey As Variant
    Dim c As Range
    Dim v As Variant
    Dim wkSh As Worksheet
    Dim flagCSV As Boolean

    Application.ScreenUpdating = False

    Set dicX = CreateObject("Scripting.Dictionary")
    Set dicCSV = CreateObject("Scripting.Dictionary")
    Set dicCnt = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")     '元シート
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        flagCSV = False
            v = Array(c.Value, c.Offset(, 1).Value, c.Offset(, 2).Value)
            If WorksheetFunction.CountIf(.Columns("A"), c.Value) = 1 Then
                flagCSV = True
            Else
                If dicCnt.exists(c.Value) Then
                    If dicCnt(c.Value) >= 5 Then flagCSV = True
                End If
            End If

            If flagCSV Then
                k = k + 1
                dicX(k) = v
            Else
                dicCnt(c.Value) = dicCnt(c.Value) + 1
                z = z + 1
                dicCSV(z) = v
            End If
        Next
        .Cells.ClearContents
        .Range("A1:C1").Resize(dicX.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicX.items))
    End With

    Sheets.Add
    Set wkSh = ActiveSheet
    wkSh.Range("A1:C1").Resize(dicCSV.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicCSV.items))

    Call GenCsv(wkSh)

    Application.DisplayAlerts = False
    wkSh.Delete
    Application.DisplayAlerts = True

    Set dicX = Nothing
    Set dicCSV = Nothing
    Set dicCnt = Nothing
    Set wkSh = Nothing

    Application.ScreenUpdating = True

    MsgBox "処理が完了しました"

 End Sub

 Private Sub GenCsv(sh As Worksheet)
    Dim idCsv As Long
    Dim z As Long, x As Long, i As Long
    Dim myPath As String

    myPath = "C:\TEST\"       '★保存フォルダ。実際のものに。
    z = (sh.Range("A" & Rows.Count).End(xlUp).Row - 1) \ 10
    Workbooks.Add
    If z Mod 10 > 0 Then z = z + 1
    For i = 1 To z
        x = (i - 1) * 10 + 1
        Cells.Clear
        Range("A1:C10").Value = sh.Range("A" & x & ":C" & x + 9).Value
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=myPath & Format(idCsv, "0000") & ".csv", _
                                        FileFormat:=xlCSV, CreateBackup:=False
        Application.DisplayAlerts = True
        idCsv = idCsv + 1
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Close saveChanges:=False
    Application.DisplayAlerts = True

 End Sub

 (ぶらっと)

お返事が遅くなりました。

作成して頂いたコードで実行した所、1回目は正常に動いたのですが、
何度か実行していくと

wkSh.Range("A1:C1").Resize(dicCSV.Count).Value = _

            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicCSV.items))

の部分でエラーが発生するようです。
何度も何度も作成して頂いたにも関わらず申し訳御座いません。

（九九）

 私のコードは試したのかな？
 (seiya)

すみません、seiyaさんのコードを見逃しておりました。

出力条件に合計10件分になったらCSVに出力、というものがあり

試してみたところ、頂いたコードでは10件分になる前に出力されてしまうようです。

折角製作して頂いたのに申し訳御座いません。

（九九）

 種々雑多なＩＤが混在してもよいのですか？
 (seiya)

 出現順でばらばらの状態（事前にデータを並び替えしておけば別ですが)でもよければ

 VSortM a, 1, n, 2

 の行を削除してください。

 Sub test()
Dim i As Long, ii As Long, rng As Range, r As Range, txt As String, x
Dim a, n As Long, temp, t As Long, w()
Set rng = Range("a1").CurrentRegion.Resize(, 3)
ReDim a(1 To rng.Rows.Count, 1 To 2)
With CreateObject("Scripting.Dictionary")
    For Each r In rng.Columns(1).Cells
        If Not .exists(r.Value) Then
            n = n + 1
            a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
            a(n, 2) = r.Value
            .Item(r.Value) = 1
            r.ClearContents
        Else
            If .Item(r.Value) < 5 Then
                n = n + 1
                a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
                a(n, 2) = r.Value
                .Item(r.Value) = .Item(r.Value) + 1
            End If
        End If
    Next
End With
rng.Columns(1).SpecialCells(4).EntireRow.Delete
VSortM a, 1, n, 2      '<- ここ
For i = 1 To n Step 10
    ii = 0
    Do While ii <= 9
        txt = txt & vbCrLf & a(i + ii, 1)
        If i + ii + 1 > n Then Exit Do Then Exit Do
        ii = ii + 1
    Loop
    t = t + 1
    Open ThisWorkbook.Path & "\" & Format$(t, "0000") & ".csv" For Output As #1
        Print #1, Mid$(txt, 3)
    Close #1
    txt = ""
Next
End Sub

 Private Sub VSortM(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, temp
i = UB: ii = LB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
    Do While ary(ii, ref) < M
        ii = ii + 1
    Loop
    Do While ary(i, ref) > M
        i = i - 1
    Loop
    If ii <= i Then
        For iii = LBound(ary, 2) To UBound(ary, 2)
            temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
        Next
        ii = ii + 1: i = i - 1
     End If
Loop
If LB < i Then VSortM ary, LB, i, ref
If ii < UB Then VSortM ary, ii, UB, ref
End Sub
(seiya)

 >何度か実行していくと ・・・・の部分でエラーが発生するようです。

 ・そのときのエラーメッセージを教えて
 ・黄色く光ったこのコードの　dicCSV.Count　にカーソルを当てると、その値がポップアップされる。
　それを教えて。

 追記）★★★
　　何度かやっていると・・・・で、こちらでも、同じところでエラーになった。
　　もう、重複したものはなく、ＣＳＶに持って行くデータがないときにそうなる。
　　そちらでも、その条件だった？
　　とりあえず、その場合のエラーを回避するコードを書いてみる。

 (ぶらっと)

 エラー回避バージョン
 なお、GenCsvプロシジャは変更なし。

 Sub Sample5()
    Dim dicX As Object    '残すデータ
    Dim k As Long         '残すデータコントロール
    Dim dicCSV As Object   'CSV用（データ）
    Dim dicCnt As Object   'CSV用（件数）
    Dim z As Long          'CSVコントロール
    Dim dKey As Variant
    Dim c As Range
    Dim v As Variant
    Dim wkSh As Worksheet
    Dim flagCSV As Boolean

    Application.ScreenUpdating = False

    Set dicX = CreateObject("Scripting.Dictionary")
    Set dicCSV = CreateObject("Scripting.Dictionary")
    Set dicCnt = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")     '元シート
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        flagCSV = False
            v = Array(c.Value, c.Offset(, 1).Value, c.Offset(, 2).Value)
            If WorksheetFunction.CountIf(.Columns("A"), c.Value) = 1 Then
                flagCSV = True
            Else
                If dicCnt.exists(c.Value) Then
                    If dicCnt(c.Value) >= 5 Then flagCSV = True
                End If
            End If

            If flagCSV Then
                k = k + 1
                dicX(k) = v
            Else
                dicCnt(c.Value) = dicCnt(c.Value) + 1
                z = z + 1
                dicCSV(z) = v
            End If
        Next
        .Cells.ClearContents
        .Range("A1:C1").Resize(dicX.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicX.items))
    End With

    If dicCSV.Count = 0 Then
        MsgBox "重複したデータはありません"
    Else
        Sheets.Add
        Set wkSh = ActiveSheet
        wkSh.Range("A1:C1").Resize(dicCSV.Count).Value = _
                WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicCSV.items))

        Call GenCsv(wkSh)

        Application.DisplayAlerts = False
        wkSh.Delete
        Application.DisplayAlerts = True
    End If

    Set dicX = Nothing
    Set dicCSV = Nothing
    Set dicCnt = Nothing
    Set wkSh = Nothing

    Application.ScreenUpdating = True

    MsgBox "処理が完了しました"

 End Sub

 (ぶらっと)

 これでどうでしょう？

 Sub test()
Dim i As Long, ii As Long, rng As Range, r As Range, txt As String, x
Dim a, n As Long, temp, t As Long, w(), e
Set rng = Range("a1").CurrentRegion.Resize(, 4)
ReDim a(1 To rng.Rows.Count, 1 To 3)
With CreateObject("Scripting.Dictionary")
    For Each r In rng.Columns(1).Cells
        If Not .exists(r.Value) Then
            n = n + 1
            a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
            a(n, 2) = r.Address(0, 0)
            a(n, 3) = r.Value
            .Item(r.Value) = 1
        Else
            If .Item(r.Value) < 5 Then
                n = n + 1
                a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
                a(n, 2) = r.Address(0, 0)
                a(n, 3) = r.Value
                .Item(r.Value) = .Item(r.Value) + 1
            End If
        End If
    Next
    For i = 1 To n
        If .Item(a(i, 3)) = 1 Then
            a(i, 3) = Empty
            t = t + 1
        Else
            a(i, 3) = .Item(a(i, 3)) & "-" & a(i, 3)
            Range(a(i, 2)).ClearContents
        End If
    Next
    Columns(1).SpecialCells(4).EntireRow.Delete
End With
VSortM a, 1, n, 3
n = n - t: t = 0
For i = 1 To n
    ii = 0
    Do While ii <= 9
        txt = txt & vbCrLf & a(i + ii, 1)
        ii = ii + 1
        If i + ii > n Then Exit Do
    Loop
    Open ThisWorkbook.Path & "\" & Format$(t, "0000") & ".csv" For Output As #1
        Print #1, Mid$(txt, 3)
    Close #1
    txt = ""
    t = t + 1
    i = i + ii - 1
    If i >= n Then Exit For
Next
If t = 0 Then MsgBox "該当データ無"
End Sub

 Private Sub VSortM(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, temp
i = UB: ii = LB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
    Do While ary(ii, ref) > M
        ii = ii + 1
    Loop
    Do While ary(i, ref) < M
        i = i - 1
    Loop
    If ii <= i Then
        For iii = LBound(ary, 2) To UBound(ary, 2)
            temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
        Next
        ii = ii + 1: i = i - 1
     End If
Loop
If LB < i Then VSortM ary, LB, i, ref
If ii < UB Then VSortM ary, ii, UB, ref
End Sub
(seiya)

お二方とも、作成して頂き大変ありがとう御座いました。

ほぼ理想的な動作をしています。

ただ、全面的に私の書き方が悪かったのですが、重複してないデータ（1行しかなくても）も、

1データとして扱いたかったのですが、お二方のコードでは重複してるデータしか格納していないものでした。

時間をかけて作成して頂いたのにも関わらず、

私の不手際でお手数をおかけして大変申し訳御座いませんでした。

（九九）

 差し替え
 Sub test()
Dim i As Long, ii As Long, rng As Range, r As Range, txt As String, x
Dim a, n As Long, temp, t As Long, w(), e
Set rng = Range("a1").CurrentRegion.Resize(, 4)
ReDim a(1 To rng.Rows.Count, 1 To 3)
With CreateObject("Scripting.Dictionary")
    For Each r In rng.Columns(1).Cells
        If Not .exists(r.Value) Then
            n = n + 1
            a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
            a(n, 2) = r.Address(0, 0)
            a(n, 3) = r.Value
            .Item(r.Value) = 1
        Else
            If .Item(r.Value) < 5 Then
                n = n + 1
                a(n, 1) = Join$(Application.Transpose(Application _
                .Transpose(r.Resize(, 3))), ",")
                a(n, 2) = r.Address(0, 0)
                a(n, 3) = r.Value
                .Item(r.Value) = .Item(r.Value) + 1
            End If
        End If
    Next
    For i = 1 To n
        a(i, 3) = .Item(a(i, 3)) & "-" & a(i, 3)
        Range(a(i, 2)).ClearContents
    Next
    Columns(1).SpecialCells(4).EntireRow.Delete
End With
VSortM a, 1, n, 3
t = 0
For i = 1 To n
    ii = 0
    Do While ii <= 9
        txt = txt & vbCrLf & a(i + ii, 1)
        ii = ii + 1
        If i + ii > n Then Exit Do
    Loop
    Open ThisWorkbook.Path & "\" & Format$(t, "0000") & ".csv" For Output As #1
        Print #1, Mid$(txt, 3)
    Close #1
    txt = ""
    t = t + 1
    i = i + ii - 1
    If i >= n Then Exit For
Next
If t = 0 Then MsgBox "該当データ無"
End Sub
(seiya)

 じゃぁ　以下。GenCsvプロシジャは変更なし。
 Sub Sample6()
    Dim dicX As Object    '残すデータ
    Dim k As Long         '残すデータコントロール
    Dim dicCSV As Object   'CSV用（データ）
    Dim dicCnt As Object   'CSV用（件数）
    Dim z As Long          'CSVコントロール
    Dim dKey As Variant
    Dim c As Range
    Dim v As Variant
    Dim wkSh As Worksheet
    Dim flagCSV As Boolean

    Application.ScreenUpdating = False

    Set dicX = CreateObject("Scripting.Dictionary")
    Set dicCSV = CreateObject("Scripting.Dictionary")
    Set dicCnt = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")     '元シート
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            flagCSV = False
            v = Array(c.Value, c.Offset(, 1).Value, c.Offset(, 2).Value)
            If dicCnt.exists(c.Value) Then
                If dicCnt(c.Value) >= 5 Then flagCSV = True
            End If

            If flagCSV Then
                k = k + 1
                dicX(k) = v
            Else
                dicCnt(c.Value) = dicCnt(c.Value) + 1
                z = z + 1
                dicCSV(z) = v
            End If
        Next
        .Cells.ClearContents
        .Range("A1:C1").Resize(dicX.Count).Value = _
            WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicX.items))
    End With

    If dicCSV.Count = 0 Then
        MsgBox "重複したデータはありません"
    Else
        Sheets.Add
        Set wkSh = ActiveSheet
        wkSh.Range("A1:C1").Resize(dicCSV.Count).Value = _
                WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicCSV.items))

        Call GenCsv(wkSh)

        Application.DisplayAlerts = False
        wkSh.Delete
        Application.DisplayAlerts = True
    End If

    Set dicX = Nothing
    Set dicCSV = Nothing
    Set dicCnt = Nothing
    Set wkSh = Nothing

    Application.ScreenUpdating = True

    MsgBox "処理が完了しました"

 End Sub

 (ぶらっと)

お二方へ。

おかげさまでファイル処理が上手くいきました。

私の説明不足の為に、何度も作成して頂き申し訳御座いません。

最後になりますが、本当にありがとうございました。

（九九）

コメント返信：

[ 一覧(最新更新順) ]

[[20110906101143]] 『CSV出力について』（九九） ページの最後に飛ぶ

[[20110906101143]]　『CSV出力について』（九九）　ページの最後に飛ぶ