• ベストアンサー

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

マクロ初心者のため教えてください SHEET1に下記のデータがあり A   B   C   D 名前 性別 年齢  クラス それをある条件(たとえば 性別が男で年齢が20歳以上)でSHEET2に一覧表として作りなおしたいのです。並び替えてやってもできるのですが、定期的な作業のため マクロでボタンを押してできるようにしたいと思っています。又データが5000件程度あるため結構毎回面倒になっています。 教えてください。 説明に不足があれば補足させていただきます よろしくお願いします

質問者が選んだベストアンサー

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.7

こんにちは。 それ自体は、あまりマクロの必要性はありません。単に、記録マクロだけで、フィルターオプションで、抽出すれば良いと思います。Accessというご意見もありますが、データ数が、10,000件ぐらいまでは、瞬時に取り出すことが可能です。 ただ、今、マクロに替えて、少しフィルターオプションに手を入れてみました。 どこか適当な場所に、このような抽出条件を置いてください。 以下のマクロでは、G1:J2 に置くことにしました。 例: 「性別が男で年齢が20歳以上」 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

hitosa
質問者

お礼

仰るとおりマクロにこだわる必要はないんですね!! やってみると 一番納得できる形のようでした ちなみに追加でおしえていただければと思うのですが この方法でファイルAのシート1からファイルBのsheet1 のにそのままデータをコピーする事も可能なんでしょうか? よろしければ教えてください

その他の回答 (7)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.8

こんばんは。 >この方法でファイルAのシート1からファイルBのsheet1 のにそのままデータをコピーする事も可能なんでしょうか? 以下のようなプログラムで出来ます。 本筋は、単純に、 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でも、あまりコピーされる秒数に影響がないようです。

hitosa
質問者

お礼

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

回答No.6

#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歳以上を求める時など 値はすべて数値で入れるようになってます。

hitosa
質問者

お礼

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

  • m_mik
  • ベストアンサー率26% (31/117)
回答No.5

マクロでということなので、ちょっと本線から外れてしまいますが、仰っている内容であればマクロを使用しなくても簡単に行うことができます。 「データ」→「フィルタ」→「オートフィルタ」を選択して、オートフィルタを設定します。 その後、年齢の部分の▼を押して「(オプション)」から20以上の条件を設定します。同様に性別の▼を押して「男」を選択します。 こうすると、条件に合致する一覧表が作成されますので、全セル選択ボタンを押してCopy/Pasteで別シートに貼り付けることができます。 (この時の全セル選択ボタンでは、合致しないセルは選択されません) このような方法もありますので、ご参考にしてください。

  • kigoshi
  • ベストアンサー率46% (120/260)
回答No.4

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

  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.3

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

noname#123709
noname#123709
回答No.2

#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

hitosa
質問者

お礼

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

noname#123709
noname#123709
回答No.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

関連するQ&A

専門家に質問してみよう