[[20160524112114]]　『条件に当てはまるリストの抽出』（にとりん）　ページの最後に飛ぶ

『条件に当てはまるリストの抽出』（にとりん）

以下の通り、元データがsheet1あります。

	A	B	C	D	E

1 分類　　名称　　場所　　種別　　数量

2 一般　　○○　　東京　　Ａ類　　 10,500

3 一般　　××　　神奈川　　Ｂ類　　 8,500

4 一般　　△△　　埼玉　　Ａ類　　 4,200

5 一般　　□□ 　　　　千葉　　Ｃ類　 2,000

これを、sheet2に「数量8,000以上の条件」、sheet3に「数量4,000以上の条件」、sheet4に「数量2,000以上の条件」、sheet5に「数量2,000未満の条件」で整理をしたいです。
例の元データはは5行しかありませんが、実際には3,000件くらいありまして、フィルターをかけて条件を抽出する方法では、抽出が困難です。

宜しくお願い致します。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

Sub 未満2000()
'
' 未満2000 Macro

 With Sheets("Sheet1")
    If Not .AutoFilterMode Then
        .Range("A1").AutoFilter
    Else
        If .FilterMode Then .ShowAllData
    End If
    .Range("A1").AutoFilter Field:=6, _
        Criteria1:="<2000", _
        Operator:=xlAnd
End With

 With Sheets("Sheet1").AutoFilter.Range
         If .SpecialCells(xlCellTypeVisible).Count > .Columns.Count Then
             .Rows.Offset(1).Resize(.Rows.Count - 1).Copy Sheets("Sheet4") _
      .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

         End If
     End With
 Sheets("Sheet1").AutoFilterMode = False
End Sub

（きき） 2016/05/24(火) 11:54

  .Range("A1").AutoFilter Field:=6　　此処　　5ですね間違いです

 .Range("A1").AutoFilter Field:=6, _
        Criteria1:="<2000", _
        Operator:=xlAnd

="<2000"此処の値を　　変えてください

          .Rows.Offset(1).Resize(.Rows.Count - 1).Copy Sheets("Sheet4") _
      .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

 Sheets("Sheet4")　　シーと変えてください

貼り付け先　　タイトル行は作成してください
（きき） 2016/05/24(火) 12:01

Sub main()

    Dim gyo(5) As Long, i As Long, tempi As Long, c As Range
    For i = 2 To 5
    Sheets("Sheet" & i).Cells.ClearContents
    Next i
    For Each c In Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 1)
        If c.Row = 1 Then
            For i = 2 To 5
            Sheets("Sheet" & i).Cells(gyo(i) + 1, 1).Resize(, 5) = c.Resize(, 5).Value
            gyo(i) = gyo(i) + 1
            Next i
        Else
            tempi = Application.WorksheetFunction.Index(Array(5, 4, 3, 2), Application.WorksheetFunction.Match(c.Offset(, 4).Value, Array(0, 2000, 4000, 8000), 1))
            Sheets("Sheet" & tempi).Cells(gyo(tempi) + 1, 1).Resize(, 5) = c.Resize(, 5).Value
            gyo(tempi) = gyo(tempi) + 1
        End If
    Next c
End Sub
（mm） 2016/05/24(火) 13:30

ききさん、mmさんありがとうございました！
（にとりん） 2016/05/24(火) 13:55

コメント返信：

[ 一覧(最新更新順) ]

[[20160524112114]] 『条件に当てはまるリストの抽出』（にとりん） ページの最後に飛ぶ

[[20160524112114]]　『条件に当てはまるリストの抽出』（にとりん）　ページの最後に飛ぶ