Ｐａｇｅ 570 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼抽出の繰り返し？ hari 03/1/19(日) 9:08 ┣Re:抽出の繰り返し？ りん 03/1/19(日) 15:48 ┃ ┗Re:抽出の繰り返し？ hari 03/1/19(日) 20:59 ┗Re:抽出の繰り返し？ Hirofumi 03/1/19(日) 17:22 ┣Re:抽出の繰り返し？ hari 03/1/19(日) 21:05 ┗Re:抽出の繰り返し？ hari 03/1/20(月) 19:15 ─────────────────────────────────────── ■題名 ： 抽出の繰り返し？ ■名前 ： hari ■日付 ： 03/1/19(日) 9:08 -------------------------------------------------------------------------
| はじめまして。超初心者の質問です。 以下のようなことはできるんでしょうか？ Ａ Ｂ 1 a 11 2 b 22 3 c 33 4 a 44 5 b 55 6 c 66 Ａの列がaのものを抽出し別のファイルに保存。 これをa→b→cと自動的に繰り返す。 オートフィルタで抽出まではいいんですが、 その後の繰り返しでつまづいています。 オートフィルタの抽出条件を変えていく、ということは可能なんでしょうか？ 可能であれば、どのようにすればいいかを教えて頂けないでしょうか？ a,b,c・・・・が2000コほどあって、 手作業ではとてもとても・・・という状態です。 どなたか、よろしくお願いします。 |
| hari さん、こんにちわ。 >以下のようなことはできるんでしょうか？ できますが。 >Ａの列がaのものを抽出し別のファイルに保存。 抽出先は ・新しいブック（フィルタ項目ごとに１ファイル） ・既存のブック（フィルタ項目ごとに１ファイル） ・既存のブック（フィルタ項目ごとに範囲が違う、ブックは一つ） ・（新しい）テキストファイル（フィルタ項目ごとに１ファイル） のどれですか？ |
| りんさん、はじめまして。 お返事、どうもありがとうございます。 >>Ａの列がaのものを抽出し別のファイルに保存。 >抽出先は > ・新しいブック（フィルタ項目ごとに１ファイル） > ・既存のブック（フィルタ項目ごとに１ファイル） > ・既存のブック（フィルタ項目ごとに範囲が違う、ブックは一つ） > ・（新しい）テキストファイル（フィルタ項目ごとに１ファイル） >のどれですか？ 既存のブック（フィルタ項目ごとに1ファイル） を考えています。 |
| >Ａの列がaのものを抽出し別のファイルに保存。 >これをa→b→cと自動的に繰り返す。 > > >a,b,c・・・・が2000コほどあって、 >手作業ではとてもとても・・・という状態です。 まさか、ファイルを2000個つくるのですか？ レコードが2000ぐらいで、Excelのファイルを作ると勝手に解釈して 余り上手く無いけど、2通りほど作って見ました １つは、オートフィルタを使わないでやり方 もう１つは、オートフィルタを使ってみました オートフィルタを使ったほうは、抽出条件を作成するのにもっと善い方法が有るような気がします 上手くいかなかったらゴメン Public Sub Test1() ' オートフィルタを使わない方法 Dim i As Long, j As Long Dim lngRowTop As Long Dim lngRowBottom As Long Dim vntData As Variant, lngDataMax As Long Dim strTmp As String Dim wksData As Worksheet Dim wksWrite As Worksheet 'Listの先頭行 lngRowTop = 1 'Listの最終行 lngRowBottom = Cells(65536, 2).End(xlUp).Row If lngRowBottom <= lngRowTop Then Beep MsgBox "データが有りません" Exit Sub End If Application.ScreenUpdating = False 'データを配列に読みこみソート Set wksData = ActiveSheet With wksData vntData = Range(.Cells(lngRowTop + 1, 1), _ .Cells(lngRowBottom, 2)).Value End With lngDataMax = UBound(vntData, 1) For i = 1 To lngDataMax vntData(i, 2) = lngRowTop + i Next i ShellSortColExcel vntData 'ファイルを作成 i = 1 Do Until i > lngDataMax strTmp = CStr(vntData(i, 1)) '新規Bookを作成 Workbooks.Add '列見出しを書きこみ With wksData Range(.Cells(lngRowTop, 1), .Cells(lngRowTop, 2)).Copy End With ActiveSheet.Paste Destination:=ActiveSheet.Cells(lngRowTop, 1) 'データの書きこみ j = 1 Do Until strTmp <> CStr(vntData(i, 1)) j = j + 1 With wksData Range(.Cells(vntData(i, 2), 1), .Cells(vntData(i, 2), 2)).Copy End With With ActiveSheet .Paste Destination:=.Cells(j, 1) End With i = i + 1 If i > lngDataMax Then Exit Do End If Loop 'ファイルの出力とClose ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & strTmp Loop Set wksData = Nothing Application.ScreenUpdating = True End Sub Public Sub ShellSortColExcel(vntList As Variant, _ Optional lngNum As Long = -1, _ Optional lngStart As Long = -1) ' ２列用シェルソート Dim i As Long Dim j As Long Dim lngGap As Long Dim vntTmp(1) As Variant Dim lngTop As Long Dim lngEnd As Long lngTop = LBound(vntList, 1) If lngStart > -1 Then If lngStart >= LBound(vntList, 1) Then lngTop = lngStart End If End If lngEnd = UBound(vntList, 1) If lngNum > -1 Then If lngTop + lngNum - 1 <= UBound(vntList, 1) Then lngEnd = lngTop + lngNum - 1 End If End If lngGap = 1 Do While lngGap < (lngEnd - lngTop + 1) \ 3 lngGap = 3 * lngGap + 1 Loop Do Until lngGap <= 0 For i = lngGap + lngTop To lngEnd vntTmp(0) = vntList(i, 1) vntTmp(1) = vntList(i, 2) For j = i To lngGap + lngTop Step -lngGap If vntList(j - lngGap, 1) <= vntTmp(0) Then Exit For End If vntList(j, 1) = vntList(j - lngGap, 1) vntList(j, 2) = vntList(j - lngGap, 2) Next j vntList(j, 1) = vntTmp(0) vntList(j, 2) = vntTmp(1) Next i lngGap = lngGap \ 3 Loop End Sub Public Sub Test2() ' オートフィルタを使う方法 Dim i As Long, j As Long Dim lngRowTop As Long Dim lngRowBottom As Long Dim vntData As Variant Dim strKey() As String Dim strTmp As String Dim rngData As Range 'Listの先頭行 lngRowTop = 1 'Listの最終行 lngRowBottom = Cells(65536, 1).End(xlUp).Row If lngRowBottom <= lngRowTop Then Beep MsgBox "データが有りません" Exit Sub End If Application.ScreenUpdating = False With ActiveSheet Set rngData = Range(.Cells(lngRowTop, 1), _ .Cells(lngRowBottom, 2)) End With '以下、Erase vntData迄が抽出条件の作成 With ActiveSheet vntData = Range(.Cells(lngRowTop + 1, 1), _ .Cells(lngRowBottom, 1)).Value End With ShellSortExcel vntData j = 0 For i = 1 To UBound(vntData, 1) If strTmp <> CStr(vntData(i, 1)) Then ReDim Preserve strKey(j) strKey(j) = CStr(vntData(i, 1)) strTmp = strKey(j) j = j + 1 End If Next i Erase vntData For i = 0 To UBound(strKey) Workbooks.Add With rngData .AutoFilter Field:=1, Criteria1:=strKey(i) .Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy End With With Cells(1, 1) .PasteSpecial .Select End With ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & strKey(i) Next i rngData.AutoFilter Set rngData = Nothing Application.ScreenUpdating = True End Sub Public Sub ShellSortExcel(vntList As Variant, _ Optional lngNum As Long = -1, _ Optional lngStart As Long = -1) ' Excel用シェルソート Dim i As Long Dim j As Long Dim lngGap As Long Dim vntTmp As Variant Dim lngTop As Long Dim lngEnd As Long lngTop = LBound(vntList, 1) If lngStart > -1 Then If lngStart >= LBound(vntList, 1) Then lngTop = lngStart End If End If lngEnd = UBound(vntList, 1) If lngNum > -1 Then If lngTop + lngNum - 1 <= UBound(vntList, 1) Then lngEnd = lngTop + lngNum - 1 End If End If lngGap = 1 Do While lngGap < (lngEnd - lngTop + 1) \ 3 lngGap = 3 * lngGap + 1 Loop Do Until lngGap <= 0 For i = lngGap + lngTop To lngEnd vntTmp = vntList(i, 1) For j = i To lngGap + lngTop Step -lngGap If vntList(j - lngGap, 1) <= vntTmp Then Exit For End If vntList(j, 1) = vntList(j - lngGap, 1) Next j vntList(j, 1) = vntTmp Next i lngGap = lngGap \ 3 Loop End Sub |
| Hirofumiさん、はじめまして。 す、すごい・・・。感激してしまいました。 >>a,b,c・・・・が2000コほどあって、 >>手作業ではとてもとても・・・という状態です。 > >まさか、ファイルを2000個つくるのですか？ ・・・申し訳ありません。0が1つ多かったようです。（笑） 200の間違いです。失礼しました。 レコードが4000くらいです。 >１つは、オートフィルタを使わないでやり方 >もう１つは、オートフィルタを使ってみました >オートフィルタを使ったほうは、抽出条件を作成するのにもっと善い方法が有るような気がします > >上手くいかなかったらゴメン とんでもありません！！！ どうもありがとうございます。 オートフィルタ使わずにもできるんですね。 じっくり眺めつつ勉強させて頂きます。 肝心のデータが今手元にありませんので試せないんですが、 明日試してみて、結果をご報告致します。 ありがとうございました。 |
| 本日確認してみたところ・・・ うまくいきました！！！！！！ どうもありがとうございました。 感激です。 まさに考えていたものそのままです。 吐き気を催すような作業が 1分やそこらで終わってしまいました・・・。 使う人が使えば、こんなことまでできちゃうんだなぁ・・・。 と痛感しました。 本当にどうもありがとうございました。 また何かの時にはどうぞよろしくお願いします。 |