EXCELのマクロを教えてください

質問

マクロ初心者のため教えてください
SHEET1に下記のデータがあり

A　　　B　　　C　　　D
名前　性別　年齢　　クラス

それをある条件（たとえば　性別が男で年齢が２０歳以上）でSHEET2に一覧表として作りなおしたいのです。並び替えてやってもできるのですが、定期的な作業のため
マクロでボタンを押してできるようにしたいと思っています。又データが５０００件程度あるため結構毎回面倒になっています。

教えてください。
説明に不足があれば補足させていただきます
よろしくお願いします

回答No.7

Wendy02 · ベストアンサー

こんにちは。

それ自体は、あまりマクロの必要性はありません。単に、記録マクロだけで、フィルターオプションで、抽出すれば良いと思います。Accessというご意見もありますが、データ数が、10,000件ぐらいまでは、瞬時に取り出すことが可能です。

ただ、今、マクロに替えて、少しフィルターオプションに手を入れてみました。

どこか適当な場所に、このような抽出条件を置いてください。

以下のマクロでは、G1:J2 に置くことにしました。

例:

「性別が男で年齢が２０歳以上」

G1:J2
名前　性別　年齢　　クラス
　　　男　　>=20

サンプルマクロ

'コントロールツールのボタンを<Sheet1>に置きます。そして、右クリックコードの表示でコードの外枠を出したら、中身を入れます。

Private Sub CommandButton1_Click()
'-------------------------中身-------
　On Error Resume Next
　Worksheets("Sheet2").Range("A1").CurrentRegion.Clear
　ThisWorkbook.Names("Database").Delete
　ThisWorkbook.Names("Criteria").Delete
　On Error GoTo 0
　With Worksheets("Sheet1")
　　 .Range("A1", .Range("A65536").End(xlUp).Offset(, 3)).AdvancedFilter _
　　 Action:=xlFilterCopy, _
　　 CriteriaRange:=.Range("G1:J2"), _
　　 CopyToRange:=Worksheets("Sheet2").Range("A1")
　End With
'----------------------------
End Sub

お礼

仰るとおりマクロにこだわる必要はないんですね！！
やってみると　一番納得できる形のようでした

ちなみに追加でおしえていただければと思うのですが
この方法でファイルＡのシート１からファイルＢのsheet１ のにそのままデータをコピーする事も可能なんでしょうか？
よろしければ教えてください

回答No.8

Wendy02

こんばんは。

＞この方法でファイルＡのシート１からファイルＢのsheet１ のにそのままデータをコピーする事も可能なんでしょうか？

以下のようなプログラムで出来ます。

本筋は、単純に、
Worksheets("Sheet2").Range("A1")
　　　↓
Workbooks("B.xls").Worksheets("Sheet1").Range("A1")

と変っただけなのです。ただ、ブックが違ったりすると、うっかり、ブックを開けないで、マクロを実行させようとしたりしますね。そのために、エラーを想定して、ちょっと長たらしいコードをつけてあります。

Const SECONDBOOKNNAME As String = "B.xls"
ここにブック名が入ります。同じフォルダなら、フォルダ名は必要ありませんが、他のフォルダの場合は、ドライブ名から、"C:\Documents and Settings\<User>\My Documents\excel\B.xls"
のように入れる必要があります。

'<シートモジュール>

Private Sub CommandButton1_Click()
Dim PasteBook As Workbook
'以下を設定してください。もし、フォルダなどの情報があれば、それも加えてください。
Const SECONDBOOKNNAME As String = "B.xls"

　On Error GoTo ErrHandler
　Set PasteBook = Workbooks(SECONDBOOKNNAME)

　On Error Resume Next
　PasteBook.Worksheets("Sheet1").Range("A1").CurrentRegion.Clear
　ThisWorkbook.Names("Database").Delete
　ThisWorkbook.Names("Criteria").Delete
　On Error GoTo 0

　Application.ScreenUpdating = False
　With ThisWorkbook.Worksheets("Sheet1")
　　 .Range("A1", .Range("A65536").End(xlUp).Offset(, 3)).AdvancedFilter _
　　 Action:=xlFilterCopy, _
　　 CriteriaRange:=.Range("G1:J2"), _
　　 CopyToRange:=Workbooks(SECONDBOOKNNAME).Worksheets("Sheet1").Range("A1")
　End With
　Application.ScreenUpdating = True

ErrHandler:
　'ブックが開いていないときに、ブックを開けます。
　If Err() = 9 Then
　Workbooks.Open SECONDBOOKNNAME
　Resume
　ElseIf Err() <> 9 And Err() > 0 Then
　　MsgBox Err.Description
　End If
　Set PasteBook = Nothing
End Sub

なお、不思議なことに、このAdvancedFilter（フィルターオプション）は、データが、5000でも、30,000でも、あまりコピーされる秒数に影響がないようです。

お礼

すごいです！！びっくりしました

もう少し勉強しないと今回の説明にはわからない部分が多いですが・・・・・
又　何かの節にはよろしくお願いします

回答No.6

minato_air

#1 さんの回答に補足+機能追加として

Sub 抽出()
Application.ScreenUpdating = False
Dim i As Long
Dim S As Integer
S = InputBox("性別はどちらですか？" & Chr(10) & "男 = (1) 女 = (2) 両方 = (3)")
Dim N As Integer
N = InputBox("年齢は幾つ以上(以下)ですか？")
Dim F As Integer
F = InputBox("抽出条件は以上ですか？以下ですか？" & Chr(10) & "不等号( より大きい = (1) 、より小さい = (2)、" & Chr(10) & " 以上 = (3)、 以下 = (4)、だけ = (5) " & Chr(10) & "数値でお答え下さい")

Sheets("sheet2").Range("A2:D" & Sheets("sheet2").Range("D65536") _
.End(xlUp).Row).ClearContents
With Sheets("sheet1")
For i = 2 To .Range("A65536").End(xlUp).Row

Select Case S
Case 1

Sex = "男"

Select Case F
Case 1
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value > N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 2
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value < N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 3
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value >= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 4
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value <= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 5
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value = N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case Else
MsgBox "数値で入力下さい。"
End Select

Case 2
Sex = "女"

Select Case F
Case 1
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value > N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 2
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value < N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 3
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value >= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 4
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value <= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 5
If .Cells(i, 2).Value = Sex And .Cells(i, 3).Value = N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case Else
MsgBox "数値で入力下さい。"
End Select

Case 3
Sex = "男"
Sex2 = "女"

Select Case F
Case 1
If .Cells(i, 3).Value > N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 2
If .Cells(i, 3).Value < N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 3
If .Cells(i, 3).Value >= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 4
If .Cells(i, 3).Value <= N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case 5
If .Cells(i, 2).Value = Sex And Sex2 And .Cells(i, 3).Value = N Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Case Else
MsgBox "数値で入力下さい。"
End Select

Case Else
MsgBox "数値で入力下さい。"
End Select

Next i
End With
Application.ScreenUpdating = True
End Sub

これにより、わざわざ抽出条件を変えなくても、
抽出出来るようになります。
例、女性の20歳以上を求める時など

値はすべて数値で入れるようになってます。

お礼

いろんなことが出来ることにびっくりしました
ありがとうございます

回答No.5

m_mik

マクロでということなので、ちょっと本線から外れてしまいますが、仰っている内容であればマクロを使用しなくても簡単に行うことができます。

「データ」→「フィルタ」→「オートフィルタ」を選択して、オートフィルタを設定します。
その後、年齢の部分の▼を押して「（オプション）」から20以上の条件を設定します。同様に性別の▼を押して「男」を選択します。
こうすると、条件に合致する一覧表が作成されますので、全セル選択ボタンを押してCopy/Pasteで別シートに貼り付けることができます。
（この時の全セル選択ボタンでは、合致しないセルは選択されません）

このような方法もありますので、ご参考にしてください。

回答No.4

kigoshi

「性別が男で年齢が２０歳以上」といった個別具体的な抽出に対応するだけではなく、いろいろな条件に柔軟に対応しなければならないのだとしたら、その条件の与え方をどのように想定しているのか示していただく必要があると思います。
それによってはExcelのマクロでも十分対応可能かと思います。
しかしこういった事例は通常はAccessの守備範囲かと思います。Accessへの移行を検討されてはいかがでしょうか。

回答No.3

merlionXX

Sub Macro1()
Sheets("Sheet1").Rows("1:1").Select
With Selection
.AutoFilter
.AutoFilter Field:=2, Criteria1:="男"
.AutoFilter Field:=3, Criteria1:=">=20", Operator:=xlAnd
End With
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Sheet1").Rows("1:1").AutoFilter
End Sub

回答No.2

noname#123709

＃1です。ごめんなさい。
改行して欲しくないところで改行となってしまいましたので再度。
Sub 抽出()
Application.ScreenUpdating = False
Dim i As Long

Sheets("sheet2").Range("A2:D" & Sheets("sheet2").Range("D65536") _
.End(xlUp).Row).ClearContents
With Sheets("sheet1")
For i = 2 To .Range("A65536").End(xlUp).Row
If .Cells(i, 2).Value = "男" And .Cells(i, 3).Value >= 20 Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:= _
Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

お礼

早速ありがとうございました
参考にさせていただきます

回答No.1

noname#123709

標準モジュールですが、下記のような感じでしょうか？

Sub 抽出()
Application.ScreenUpdating = False
Dim i As Long

Sheets("sheet2").Range("A2:D" & Sheets("sheet2").Range("D65536").End(xlUp).Row).ClearContents
With Sheets("sheet1")
For i = 2 To .Range("A65536").End(xlUp).Row
If .Cells(i, 2).Value = "男" And .Cells(i, 3).Value >= 20 Then
.Range(.Cells(i, 1), .Cells(i, 4)).Copy Destination:=Sheets("sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Next i
End With
Application.ScreenUpdating = True
End Sub