Results of 1 - 1 of about 37697 for IF (0.007 sec.)
- [[20110906101143]]
- #score: 1591
- @digest: 40b041c69d40db70be95d32a1807f521
- @id: 55823
- @mdate: 2011-09-09T08:56:25Z
- @size: 27686
- @type: text/plain
- #keywords: diccsv (171838), diccnt (167167), flagcsv (103331), idcsv (73808), gencsv (59986), wksh (55341), dicx (41908), 九九 (33916), vsortm (31196), 一デ (14361), ルdi (13841), displayalerts (11294), transpose (10130), 元シ (8079), application (6070), worksheetfunction (6006), mypath (5513), ary (5379), scripting (5122), dictionary (4618), ii (4222), temp (3855), value (3851), createobject (3760), items (3754), 同一 (3724), item (3538), screenupdating (3235), 出力 (3130), csv (3059), resize (2931), activeworkbook (2855)
- 『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件まで抜き出したいという事です。 説明が下手で申し訳ないです。 （九九） ---- わぁ、今、A,B,C連結値で同一チェックしたものを書き上げてアップしようとしたところ。 はい、書きなおします。 (ぶらっと) ---- さぁ、どうだろうか。まだ要件を誤解しているか。 絶対に文句を言われそうなところがある。出力のCSV,かならずしも、元シートに現れた上のほうから まとめているわけじゃない。 ここも、元シート順ということであれば、ちょっと大変だなぁ。処理をがらっとかえる必要がでてくるかも。 追記）↑ と書いた後、やっぱり誤解してるのかなぁと。 CSVには重複分を1行にして持っていってるけど、きっとそうじゃなく、重複行を そのまま持っていくんだろうなぁ。まぁ、とりあえず試してみて。 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 'ユニークキー A列を直接使ってもいいけど、 '将来、要件変更で複数列のコンバインが必要になった時の '対応を容易にするためにD列を使う。 .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) '抽出結果をもとにCSV作成処理 '元シートメンテナンス 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行を移す）、のつもりでした。 わざわざ作成して頂いたのに申し訳ないです。 また、上記のマクロを実行したところ、 並べ替えの参照が正しくありません。参照が並べ替えるデータ内にあることと、 [最優先されるキー]ボックスが空白でないことを確認してください。 と、エラー文が表示されました。 （九九） ---- とりあえず書きなおしてみた。今までのものはすべて捨てて以下。 でも、まだ、誤解してるところとか、ありそうだなぁ。 もう並び替えは使わないんだけど、 >並べ替えの参照が正しくありません。参照が並べ替えるデータ内にあることと、 >[最優先されるキー]ボックスが空白でないことを確認してください。 >と、エラー文が表示されました。 こちらでは（実行結果は別にして）エラーはでていない。ということは、こちらで想定している 元シートのレイアウトが違うのかな? こちらの理解は、1行目からデータ。 あぁ、それと、コードは標準モジュールに。（念のため） 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) ---- アップしたコードをつらつら眺めていたら出力を5行ごとにしてた。 >合計10行集まったらCSVファイルに出力し、 なので、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件分になる前に出力されてしまうようです。 折角製作して頂いたのに申し訳御座いません。 （九九） ---- 種々雑多なIDが混在してもよいのですか? (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 にカーソルを当てると、その値がポップアップされる。 それを教えて。 追記）★★★ 何度かやっていると・・・・で、こちらでも、同じところでエラーになった。 もう、重複したものはなく、CSVに持って行くデータがないときにそうなる。 そちらでも、その条件だった? とりあえず、その場合のエラーを回避するコードを書いてみる。 (ぶらっと) ---- エラー回避バージョン なお、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 (ぶらっと) ---- お二方へ。 おかげさまでファイル処理が上手くいきました。 私の説明不足の為に、何度も作成して頂き申し訳御座いません。 最後になりますが、本当にありがとうございました。 （九九）... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201109/20110906101143.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97059 documents and 608315 words.
訪問者：