• 締切済み

VBA オートフィルタで抽出したものを連続貼り付け

下記のように情報が100近くまで存在した場合に、オートフィルターで一つずつ抽出したものをコピーし、新規シートに貼り付けたいのですが、どうすれば良いのでしょうか? 1 1 1 2 2 2 3 3 3 たとえばシート1に 1 1 1     シート2に 2 2 2 といったように処理したいので、教えて下さい。 vbaの参考書とサンプルを見て下記のように作成したのですが上手くいきません。 どんな本を読めば作成出来るようになるのかわからず、質問させていただきました。 ub オートフィルター() Dim myRng As Range Dim mySht As Worksheet Set myRng = _ Worksheets(1).Range("A1").CurrentRegion With Worksheets Set mySht = .Add(after:=.Item(.Count)) End With With myRng .AutoFilter field:=1, Criteria1:=8 On Error Resume Next .Resize(.Rows.Count - 1).Offset(1).Copy mySht.Range("A1") .SpecialCells(xlCellTypeVisible).Copy mySht.Range("A1").AutoFilter mySht.Range("A1").AutoFilter If Err.Number <> 0 Then Application.DisplayAlerts = False mySht.Delete Application.DisplayAlerts = True End If On Error GoTo 0 End With Set myRng = Nothing Set mySht = Nothing End Sub

みんなの回答

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

ANo2 merlionXXです。 見出し行がある場合のほうの記述に抜けがありました。 修正します。 Sub test01() '見出し行がある場合   Dim ws(1) As Worksheet   Dim myW   Dim i As Long   Set myDic = CreateObject("Scripting.Dictionary")   Set ws(0) = ActiveSheet   Set myRng = ws(0).Range("A1").CurrentRegion   myW = myRng.Columns(1).Value   For i = 1 To UBound(myW)     If Not myDic.Exists(myW(i, 1)) Then       myDic.Add myW(i, 1), ""     End If   Next i   With ws(0)     For i = 2 To myDic.Count       .AutoFilterMode = False       myRng.Rows(1).AutoFilter       myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)       Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))       myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")     Next i   End With End Sub

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

ご質問に提示されたデータでは見出し行がないようですが、オートフィルターというからには1行目に見出し行がないのが不思議です。 (見出しなしでオートフィルターを設置すると、1行目は常に表示されますので) 単に省略しただけなのでしょうか? 一応、最初のデータに見出し行がある場合と、ない場合の二つの例を書きます。 別シートに転記の際は、ご提示のように見出し行はつけていません。 フィルタをかけるための重複なしのリストの作成には.Dictionaryオブジェクトを利用しました。 ご参考まで。 Sub test01() '見出し行がある場合   Set myDic = CreateObject("Scripting.Dictionary")   Set ws(0) = ActiveSheet   Dim i As Long   Set myRng = ws(0).Range("A1").CurrentRegion   myW = myRng.Columns(1).Value   For i = 1 To UBound(myW)     If Not myDic.Exists(myW(i, 1)) Then       myDic.Add myW(i, 1), ""     End If   Next i   With ws(0)     For i = 2 To myDic.Count       .AutoFilterMode = False       myRng.Rows(1).AutoFilter       myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)       Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))       myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")     Next i   End With End Sub Sub test02() '見出し行がない場合   Dim ws(1) As Worksheet   Dim myW   Dim myDic As Object   Dim i As Long   Set myDic = CreateObject("Scripting.Dictionary")   Set ws(0) = ActiveSheet   ws(0).Rows("1").Insert Shift:=xlDown   Set myRng = ws(0).Range("A1").CurrentRegion   myW = myRng.Columns(1).Value   For i = 2 To UBound(myW)     If Not myDic.Exists(myW(i, 1)) Then       myDic.Add myW(i, 1), ""     End If   Next i   With ws(0)     For i = 1 To myDic.Count       .AutoFilterMode = False       myRng.Rows(1).AutoFilter       myRng.AutoFilter Field:=1, Criteria1:=myDic.keys()(i - 1)       Set ws(1) = Sheets.Add(after:=Sheets(Sheets.Count))       myRng.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy ws(1).Range("A1")     Next i   End With End Sub

  • xls88
  • ベストアンサー率56% (669/1189)
回答No.1

フィルタリストを取得しリストをLoopしながらオートフィルタしてみます。 Dim mySht As Worksheet Dim myRng As Range Dim fnRng As Range Dim c As Range Dim myData() As String '---フィルタリスト Dim fn As Long '---Field番号 Dim flg As Boolean Dim i As Long ReDim myData(0) fn = 1 Set myRng = Worksheets(1).Range("A1").CurrentRegion Set fnRng = myRng.Columns(fn).Resize(myRng.Rows.Count - 1).Offset(1) 'リスト For Each c In Range(fnRng.Address) If myData(0) = "" Then myData(0) = c.value Else flg = False For i = 0 To UBound(myData) If myData(i) = c.value Then flg = True Exit For End If Next If Not flg Then ReDim Preserve myData(UBound(myData) + 1) myData(UBound(myData)) = c.value End If End If Next 'オートフィルタ With myRng For i = 0 To UBound(myData) With Worksheets Set mySht = .Add(after:=.Item(.Count)) End With .AutoFilter Field:=fn, Criteria1:=myData(i) .Resize(.Rows.Count - 1).Offset(1).Copy mySht.Range("A1") Next End With ≪参考≫ リストの取得は、下記掲示板でSALINGERさんのコードを使わせて頂きました。 特定のセル範囲を重複無しで配列に格納する http://q.hatena.ne.jp/1249216965

関連するQ&A

  • エクセルVBAのオートフィルタについて

    いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub (一部省略しています)

  • オートフィルタで抽出したデータをVBAで貼り付けしたい

    質問させていただきます。 エクセルで仕入帳を作っています。 各取引先ごとに1枚のシートになっているのですが、 該当する月をオートフィルタで抽出して、そのデータを1枚のシートに貼り付けていき、各月ごとにデータをまとめたいと思っています。 ユーザーフォームで月を入力してオートフィルタで抽出しているのですが、データのないシートの場合不要な部分までコピー&ペーストされてしまいます。 これを回避するにはどのようにコードをかけばいいのでしょうか。 よろしくお願い致します。 現在はこのようなコードで抽出しています。 Private Sub CommandButton1_Click() Application.ScreenUpdating = False Worksheets("sheet2").Select Range("H1:H17").Select Range("H17").Activate Selection.AutoFilter Field:=8 Rows("2:2").Select Rows("2:500").Select Selection.ClearContents RowIndex = 3 '行番号の初期値設定 Do While Worksheets("目次").Cells(RowIndex, 1).Value <> "" '拾ったセルの値が空でない間ループ内の処理をする 検索値 = UserForm1.TextBox1.Text DataSheetName = Worksheets("目次").Cells(RowIndex, 1).Value Worksheets(DataSheetName).Select Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.AutoFilter Selection.AutoFilter Field:=13, Criteria1:=検索値 & "月分" Set tbl = ActiveCell.CurrentRegion tbl.Offset(2, 0).Resize(tbl.Rows.Count - 2, tbl.Columns.Count).Select Selection.Copy Worksheets("sheet2").Select IRow = Range("A" & Rows.Count).End(xlUp).Row Range("A" & IRow + 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Worksheets(DataSheetName).Select Selection.AutoFilter Field:=13 RowIndex = RowIndex + 1 '行番号カウントアップ Loop Application.ScreenUpdating = True Worksheets("sheet2").Select Range("A2").Select Unload UserForm1 End Sub

  • VBAで列が可変のオートフィルの実装

    元となるSheet1のR列を「Sheet1~3」以外のシートの名前で オートフィルターさせてその内容をコピーし、数式を代入させたあと、連続データをEの列の最終セルまで 連続させてコピーするという下記のVBAを実装しました・・・が 連続データさせるEの列が1つしかなかった場合、連続データできないのでエラーが起きてしまします ですのでそれは無視してよいと単純に「On Error Resume Next」で処理しちゃってます でもこれでは、あまり良くない処理のような気がするのですが・・・ 連続データ出来ない場合は、1つのセルに数式を代入するだけでおしまい というプログラム処理はどのようにやればいいのでしょうか? ' オートフィルター For Each sh In Worksheets If sh.Name <> "Sheet1" And sh.Name <> "Sheet2" And sh.Name <> "Sheet3" Then Dim Filtarget As Range Dim Maction As Range 'コピーの開始する場所 Set Filtarget = Sheets(sh.Name).Range("A4") Set Maction = Sheets(sh.Name).Range("W4") Set Fills = Sheets(sh.Name).Range("X4") With Sheets("Sheet1").Range("R3") .AutoFilter Field:=18, Criteria1:=sh.Name .CurrentRegion.Copy With Worksheets.Add .Paste .Range("1:3").Delete .UsedRange.Copy Filtarget .Range("X1").Formula = "=E1/W1" .Range("M1:M" & Cells(Rows.Count, 13).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Maction .Range("X1").AutoFill Destination:=Range("X1:X" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeVisible) On Error Resume Next .Range("X1:X" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeVisible).NumberFormatLocal = "\#,##0;\-#,##0" .Range("X1:X" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Fills Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With .AutoFilter Field:=18 End With End If Next 以上、よろしくお願い致します。

  • エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

    フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

  • VBA のオートフィルタについて

    ExcelVBA初心者でございます。 2点質問がございます。 (1)エクセルVBAのオートフィルタの機能を使い、"マスタ0701"シートの13行目が”ABC”の行を、"検索結果"というシートにコピーしたいです。 以下のマクロを実行しますと、まず"マスタ0701"のB1のセル(13行目はブランク)がコピーされ、その下に13行目が”ABC”に該当する行がコピーされます。 なぜ、B1セルまでコピーされるのかご教示頂けますと幸いです。 (2)また検索結果だけでなく、オートフィルタのタイトル行もコピーするようにするにはどうしたら良いでしょうか? よろしくお願いいたします。 Sub 絞り込み() With Worksheets("マスタ0701").Range("A1") .AutoFilter Field:=13, Criteria1:="ABC" .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("検索結果").Range("A1") .AutoFilter End With End Sub

  • VBA 変数について

    VBA初心者でございます。 VBAでgrpという変数を設定し、それをキーにしてオートフィルタをしたいです。 以下のコードではエラーがでてしまうのは、なぜでしょうか? どうぞ宜しくお願いいたします。 Sub 絞り込み2() Dim grp Set grp = Worksheets("リスト").Cells(3, 2) Worksheets("マスタ0701").AutoFilterMode = False With Worksheets("マスタ0701").Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)) .AutoFilter Field:=13, Criteria1:=grp '.CurrentRegion.Select Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)).SpecialCells(xlVisible).Copy Worksheets("検索結果").Range("A1") '.AutoFilter End With End Sub

  • エクセルVBA:コピーの貼り付け先

    VBA初心者です。よろしくお願いします。 あるデータベースをセルB2に入力されている値で絞込み、 シート2に貼り付けるとき、下記の(1)がおそらく正解だと思いますが、 ★(質問1) (2)でも同じ結果が得られました。コピー先の目的地を示す「Destination:=」の部分は省略して全く問題なしと考えてよろしいのでしょうか? ★(質問2) (3)で試してみても同じ結果が得られました。range("sheet2!A1") なんて書き方は、たまたま、試してみたらできちゃった(同じ結果が得られた)のですが、使い方として問題ありませんか? ------------------------------------------------------------- (1) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1") .AutoFilter End With End Sub -------------------------------------------------------------- (2) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Sheets("Sheet2").Range("A1") .AutoFilter End With End Sub -------------------------------------------------------------- (3) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Range("Sheet2!A1") .AutoFilter End With End Sub

  • エクセルマクロで、他ブックからオートフィルタ抽出

    エクセルで別ブックで作成してあるカレンダーから、稼働日を判断して指定した期間の日付をオートフィルターを使って抽出したいのですが、うまくいきません。 このようなコードを記述しましたが、別ブックでオートフィルターを使用する事はできるのでしょうか? Dim book1 As Workbook '変数book1をワークブック型で宣言 Dim book2 As Workbook '変数book2をワークブック型で宣言 Dim today As Date Set book1 = Application.ActiveWorkbook 'アクティブになっているブックをbook1へセット Application.ScreenUpdating = False '画面の更新を止める '↓アドレスのブックを開く事までbook2にセット(ReadOnly:=Trueで読み込み専用) Set book2 = Application.Workbooks.Open("\\sv\C1\\稼働日カレンダー.xls", ReadOnly:=True) today = Date maxdate = cdate("2014/3/3") ' book2.Worksheets("DATA").Cells.Copy Destination:=book1.Worksheets("Sheet1").Range("A1") '----オートフィルタでデータを抽出 With book2.Worksheets("Sheet1").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=1, Criteria1:=">=" & today, Operator:=xlAnd, Criteria2:="<=" & maxdate ' .AutoFilter Field:=2, Criteria1:="=" & 1 '----抽出データをコピー&貼り付け .Copy ActiveSheet.Range("A" & maxrow) .AutoFilter End With ' Range("A1").Select Application.ScreenUpdating = True Set book1 = Nothing '変数book1を開放 book2.Close SaveChanges:=False 'book2を閉じる(SaveChanges:=Falseで保存せずに終了) Application.ScreenUpdating = True '画面の更新を再開する Set book2 = Nothing '変数book2を開放

  • VBAでオートフィルを使って指定する文字列を含むものを表示させたい

    VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは*をつけるのはわかるのですが、 いろいろやってみましたがダメでした。(単純なことかもしれないですけど) Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub

  • ブック全体の検索の次へは?

    ブック全体を検索するマクロ作ったのですが、 ブックの最初にあるものしか見つけられません。 見つかった時に、次の検索を行うにはどのようなVBAになるのでしょうか? よろしくお願いもうしあげます。 Sub KensakuAll() 'ブック内の全シートを検索   Dim myWb As Workbook   Dim mySht As Worksheet   Dim myRng As Range   Dim Key1 As String   Key1 = InputBox("検索キーを入力しなさい")   If Key1 = "" Then Exit Sub   For Each mySht In Sheets     Set myRng = mySht.Cells.Find(what:=Key1)     If Not myRng Is Nothing Then       mySht.Activate       myRng.Activate       Set mySht = Nothing       Set myRng = Nothing       Exit Sub     End If   Next   MsgBox "該当するセルは見つかりませんでした"   Set mySht = Nothing   Set myRng = Nothing End Sub

専門家に質問してみよう