[[20051201212008]]　『データを別シートへ抽出』（みつ）　ページの最後に飛ぶ

『データを別シートへ抽出』（みつ）
下表の１から5000のデータがSheet1にあります。A列のS1をSheet2へA列のS2をSheet3を抽出したいのですが、なかなかうまくいきません。現在はオートフィルタにて別シートへコピーしていますが時間がかかり過ぎてしまう為ご教授おねがいします。

        A　 B　 C  
  1　   S1  T8  1
  2     S2  T8  2
  3     S3  T5  3
  4     S2  T5  4

 5000   S50 T5  3

 Sheet2
        A   B   C
  1　   S1  T8  1
  2
  3
  4

 Sheet3
        A   B   C
  1　   S2  T8  2
  2     S2  T5  4
  3
  4

 ◆関数による方法です！

 ◆S1を抽出するシートのシート名を「S1」にします
 ◆シート「S1」
 	A	B	C	D	E	F
 1	S1	T8	1		S1	1

 ◆E1の式
 E1=REPLACE(CELL("FILENAME",A1),1,FIND("]",CELL("FILENAME",A1)),)
 ★シート名の「S1」は表示されます

 ◆F列を作業列に！
 F1=IF(Sheet1!A1=$E$1,ROW(Sheet1!A1),"")
 ★下にコピー

 ◆A1の式
 A1=IF(ROW(A1)>COUNT($F:$F),"",INDEX(Sheet1!A:A,SMALL($F:$F,ROW(A1))))
 ★右・下にコピー

 ◆S1の行が表示されているはずです！
 ◆S1のシートを作成します！
 ◆Ctrlを押しながら、S1のシート名タブを選択しで、右にドラッグします
 ◆シート「S1(2)」がコピーされます
 ◆シート名を「S2」に変更すると、S2の行が表示されたシートが作成されます

 ◆いかがでしょうか！
 （Maron)

 ↓と同様に、フィルタオプションの設定を使う方法もあります。
[[20051201143119]]『行の上詰め抽出』

 マクロの自動記録を利用して作成したものです。
なお、Sheet1の1行目には列見出しが
	A	B	C
1	見出し1	見出し2	見出し3
　
抽出条件はSheet1のE1:F2に
	E	F
1	見出し1	見出し1
2	S1	S2
と記述しています。いかがでしょうか？(Hatch)
　
Sub Macro1()
    Worksheets("Sheet2").Activate
    Columns("A:C").ClearContents
    Sheets("Sheet1").Range("A1:C5501").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Worksheets("Sheet1").Range("E1:E2"), CopyToRange:=Range("A1"), Unique:=False
'---
    Worksheets("Sheet3").Activate
    Columns("A:C").ClearContents
    Sheets("Sheet1").Range("A1:C5501").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Worksheets("Sheet1").Range("F1:F2"), CopyToRange:=Range("A1"), Unique:=False
End Sub

 マクロによる方法です
 (Hatch)さんの方法より遅い&ごちゃごちゃしてますが
 例のごとく参考程度にこんなやりかたも・・・と

 Sheets1からFindを使って検索して一行ずつコピーしてます。
 ヒット数が増えるともちろん処理時間も遅くなります。
 下の部分でS1しか抽出できないので、S2はもう一つ作る必要があります。

 Dim c As Range
 Dim e As Range
 Dim F_Address As String
 Application.ScreenUpdating = False
 Set e = Sheets("Sheet2").Range("A1")
 Sheets("Sheet2").Cells.Clear
Set c = Columns(1).Find(What:="S1"， After:=Range("A1")， LookIn:=xlValues，  LookAt:= _
 xlWhole， SearchOrder:=xlByRows， SearchDirection:=xlNext， MatchCase:=True)
 If Not c Is Nothing Then
 F_Address = c.Address
 Do
 Rows(c.Row).Copy e
 Set e = e.Offset(1)
 Set c = Columns(1).FindNext(c)
 Loop Until c Is Nothing Or c.Address = F_Address
 End If
 Application.ScreenUpdating = True

 PS:お急ぎでしたら回りくどくしてすいませんmm
 (Null)

 Maron様 Hatch様 Null様ありがとうございます。
 Null様もう少し詳しく教えていただけませんかね。マクロで実行してみましたがうまくいきません。

 >Null様もう少し詳しく教えていただけませんかね。
 >マクロで実行してみましたがうまくいきません。
 何を教えてほしいのでしょうか?　(アカギ)

 Sheet1にデータを入れマクロ実行したがSheet2に何も表示されません（エラー表示もなし）

 これってS1とS2だけを拾い出したいんでっか？
 S50が顔出しとるし、作業が面倒という事は何十種類かのデータをコピーしたいんと
 ちゃいまっか？
 必要なだけシートを作成して試してみてくらはい。
 せやけど、何十種類もあるんやったらシート名をS1とかS2とかにしとく方が利便性に
 長けてますわなぁ。
 もしそうならSheets("sheet" & i)をSheets(tbl(i, 1))に変えて貰たらOKですワ。
 （２ヶ所ありますから気ぃ付けて！）
       （弥太郎）
 '-------------------
 Option Explicit
 Sub copy()
    Dim maxrow As Long, i As Long, Cnt As Long
    Dim tbl

    Application.ScreenUpdating = False
    With Sheets("sheet1")
        maxrow = .Range("a" & Excel.Rows.Count).End(xlUp).Row
        .Cells(1, 1).Resize(maxrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Cells(1, 1).Resize(maxrow).SpecialCells(xlCellTypeVisible).copy _
                Destination:=Range("iv30000")
        Cnt = .Cells(1, 1).Resize(maxrow).SpecialCells(xlCellTypeVisible).Count
        tbl = .Range("iv30000").Resize(Cnt).Value
        .Range("iv30000:iv65536").Clear
        .ShowAllData

        For i = 2 To Cnt
            Sheets("sheet" & i).Range("a:c").Clear
            .Range("a1").AutoFilter field:=1, Criteria1:=tbl(i, 1)
            .Range("a1").Resize(maxrow, 3).SpecialCells(xlCellTypeVisible).copy _
                    Destination:=Sheets("sheet" & i).Range("a1")
        Next i

        Application.CutCopyMode = False
        .Range("a1").AutoFilter
    End With
    Application.ScreenUpdating = True
 End Sub

 >S50が顔出しとるし、作業が面倒という事は何十種類かのデータをコピーしたいんと
 >ちゃいまっか？
 >せやけど、何十種類もあるんやったらシート名をS1とかS2とかにしとく方が利便性に
 >長けてますわなぁ。
 これらのことを考慮したつもりで、以下のように書き換えてみました。
 あちらこちらに他所様のコードを借用しています。
 フィルタオプションの設定で実行しています。　　(Hatch)
Sub tyu1203()
Dim LastRow As Long
Dim mySh As String
Dim mydSh As String
Dim mytSh As String
Dim i As Long
    Application.ScreenUpdating = False
    mydSh = "Sheet1" '---データのあるシート名
    mytSh = "Temp1" '---作業シート名
    '---作業シート
    mySh = mytSh
    ShCheck (mySh)
    '---キーの抽出
    Worksheets(mySh).Activate
    Worksheets(mySh).Cells.Clear
    LastRow = Worksheets(mydSh).Cells(65536, 1).End(xlUp).Row
    Sheets(mydSh).Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("A1"), Unique:=True
    '---
    LastRow = Worksheets(mytSh).Cells(65536, 1).End(xlUp).Row
    For i = 2 To LastRow
        mySh = Worksheets(mytSh).Cells(i, 1).Value
            ShCheck (mySh)
        Worksheets(mytSh).Range("E1").Value = Sheets(mydSh).Range("A1").Value
        Worksheets(mytSh).Range("E2").Value = mySh
        Worksheets(mySh).Activate
        Worksheets(mySh).Cells.Clear
　　　　　　'↓でデータ範囲を指定していますので要注意！
        Sheets(mydSh).Range("A1:C5501").AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=Worksheets("Temp1").Range("E1:E2"), CopyToRange:=Range("A1"), Unique:=False
    Next i
    Application.DisplayAlerts = False
    Worksheets(mytSh).Delete
    Application.DisplayAlerts = True
    '---シートの並べ替え
    ShSort
    Worksheets(mydSh).Activate
    Cells(1, 1).Select
    Application.ScreenUpdating = True
End Sub
Sub ShCheck(mySh As String)
Dim Sheet_Name As Object
    For Each Sheet_Name In Worksheets
        If Sheet_Name.Name = mySh Then Exit Sub
    Next
    Worksheets.Add.Name = mySh
End Sub
Sub ShSort()
Rem この部分は「http://www.relief.jp/itnote/archives/001300.php」から引用
Dim intLoopA As Integer
Dim intLoopB As Integer
  For intLoopA = 1 To Sheets.Count
    For intLoopB = 1 To Sheets.Count - 1
      If Sheets(intLoopB).Name > Sheets(intLoopB + 1).Name Then
        Sheets(intLoopB).Move after:=Sheets(intLoopB + 1)
      End If
    Next intLoopB
  Next intLoopA
End Sub

 ヒュッ、ヒューッ！！！
 Hatchはんビューチフル（笑
 あのぅ、！３本は「この世のモノとは思えんでけ映え」にランクされます～（笑
 　　　　（弥太郎）

 おぉ～　なんか凄く褒められたようで・・・<(｀^´)>エッヘン。
 後いくつか付け加えれば、自分的には完成です。もうちょっと弄って遊んでみます。
 では、機嫌良く一人遊びしときます(^.^)/~~~
 # あっ･･･上のコードはExcel2002で作成していますこと付け加えておきます。
 　　　　　(Hatch)

 >Null様もう少し詳しく教えていただけませんかね。
 よばれていたのにめさ放置してましたすいませんf^^

 >Sheet1にデータを入れマクロ実行したがSheet2に何も表示されません（エラー表示もなし）
 これに関してはA列に[S1]が存在しない場合
 シート名が違う場合(これはエラーが出るはずですが)
 マクロのコピー場所がSheet1のシートでない場合
 に問題がでるはずですが、ちょっと詳しくは反応できませんorz

 あとは（弥太郎）さんのコードが私が面倒がった場所をつくってくれていますし＾＾
 (Hatch)さんのは　エラーチャックも行ってくれるようなソースを書いてくれていますので、それらを見ながらどうにかなるようなきがします。
（弥太郎）さん(Hatch)さんありがとうございます＾＾
 いつも適当ですいません(Null)

 Nullはん、ほないにお礼言われたらめさ恐縮しますワ（笑
 　　　　　（弥太郎）

 エラーチェックはしていませんが、ちょっと手を加えたサンプルを下のHPにアップしときます。
http://www.geocities.jp/hatch4700/index.html のNo32　mitu.xls(約70KB)です。
 関係ないシートは削除するようにしていますので、要注意です。
 たぶんExcel2000でも完全一致になっていると思うのですが、確認はできていません。
 　　　(Hatch)　(゜;)＼(--;)オイオイ

 こちらこそ(弥太郎）さんにそういわれると照れくさいですｆ＾＾

 でもって俺のもUP
http://yakihata.jp/excel/sumple004.xls
 Excel2002　Win2000で動作確認

 (Hatch)さんのサンプルが動作はかなり速いですｂ

 (Null)

コメント返信：

[ 一覧(最新更新順) ]

[[20051201212008]] 『データを別シートへ抽出』（みつ） ページの最後に飛ぶ

[[20051201212008]]　『データを別シートへ抽出』（みつ）　ページの最後に飛ぶ