質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.49%

  • VBA

    2371questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1956questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • マクロ

    290questions

    定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

マクロ オートフィルター後指定列のコピペ Excel

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 2,315

teryyyyy2

score 11

前提・実現したいこと

マクロで取込データを、別データのフォーマットの項目でフィルターをかけ、
指定列ごとコピーしフォーマット側にペースト、
次の項目でフィルターをかけ、指定列ごとコピーしフォーマット側にペーストを繰り返し、
フォーマット側の項目がなくなったら次シートの項目でフィルターをかけて……
というループをさせ、最終シートまで繰り返す。
というマクロを作っているのですが、
オートフィルターの部分でエラーが出ます。
調べてみても原因が特定できませんでした。

Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim gyo3 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
    'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With

    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 2


    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"

    Call FileSearch(folderpass, "*.csv")
   Dim dateupdate As String
   dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
   'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
   'ThisWorkbook.Worksheets(2).Name = dateupdate '
   ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
   ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)


    Dim openbook As Workbook
    Dim openbooksheet As Worksheet
    Dim lp As Long
    Dim el As Long
    Dim br As String
    'オ
    Dim c As Range, Target As Range
    Dim LastRow As Long
    '縦軸(マクロ側シート数用)
    lp = 2
    '横軸(データ側ループ管理用)
    el = 3



    Application.ScreenUpdating = False

    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)



        Set openbooksheet = openbook.Worksheets(1)
        openbooksheet.Unprotect


      Do Until lp = 28

        Do Until Cells(el, 1) = ""

          br = ThisWorkbook.Worksheets(lp).Cells(2, el)

          openbooksheet.Activate

          Selection.AutoFilter
          openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br

          LastRow = Cells(Selection.Rows.Count, 1).End(xlUp).Row

          openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el))
          openbooksheet.Range("A1").AutoFilter


          el = el + 1

        Loop

         lp = lp + 1
      Loop



    openbook.Close False


    Application.ScreenUpdating = True
    Exit Sub
myError:
    MsgBox Err.Description
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub

試したこと

Criteria1の部分をもともとはセルで指定していたのですが、
それがいけないのかと思い変数に格納してからフィルターをかけても、
なぜかオートフィルタメソッドが失敗しましたと表記されます。
まず、この方法で綿足の考えているような動作をさせることができるのか教えていただけると幸いです。
よろしくお願いします。

補足情報

前回使用していたマクロを改変して作っているので謎の項目があるかもしれませんがご容赦ください。
追記1
あからさまにおかしい箇所が数点あったので修正しました。
追記2
ほぼ自己解決できました。

Option Explicit

Dim gyo As Long
Dim gyo2 As Long
Dim gyo3 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long
'ボタンを押したとき
Sub FolderSelect()
    'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With

    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 2


    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"

    Call FileSearch(folderpass, "*.csv")
   Dim dateupdate As String
   dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
   'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
   'ThisWorkbook.Worksheets(2).Name = dateupdate '
   ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
   ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)


    Dim openbook As Workbook
    Dim openbooksheet As Worksheet
    Dim lp As Long
    Dim el As Long
    Dim br As String
    'オ
    Dim c As Range, Target As Range
    Dim LastRow As Long
    '縦軸(マクロ側シート数用)
    lp = 2
    '横軸(データ側ループ管理用)
    el = 3



    Application.ScreenUpdating = False

    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)



        Set openbooksheet = openbook.Worksheets(1)
        openbooksheet.Unprotect


      Do Until lp = 28

        Do Until ThisWorkbook.Worksheets(lp).Cells(2, el) = ""

          br = ThisWorkbook.Worksheets(lp).Cells(2, el)

          openbooksheet.Activate

          Selection.AutoFilter
          openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br

          LastRow = 291826

          openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el))
          openbooksheet.Range("A1").AutoFilter


          el = el + 1

        Loop

         el = 3

         lp = lp + 1
      Loop



    openbook.Close False


    Application.ScreenUpdating = True
    Exit Sub
myError:
    MsgBox Err.Description
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub


データ側のシートをフォーマット側(マクロ)の各項目でフィルタをかけて
コピー、ペーストするというマクロです。
同じようなマクロを作る際の参考程度にしてください。
ただし、不要な部分も多いので要改変です。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

0

たしかオートフィルタはアクティブなシートにしか設定できなかったような気がします。
なのでエラーになっているのでは。
間違ってたらすいません…。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/06/23 14:28

    Activateしたらフィルタのエラーがなくなりました!
    ありがとうございます!

    キャンセル

  • 2016/06/23 14:47

    よかったです。
    私も前にアクティブになっていなくてはまった記憶があるので。
    Excel VBAはアクティブなシートにしかできない命令もあるので、
    疑ってみるのもよいかと思います。
    ただ、やたら何でもアクティブにするのは処理速度やプログラムのきれいさに
    かけるのでお勧めはしませんが…。

    キャンセル

  • 2016/06/23 15:12

    いいアドバイスありがとうございます。
    そうですね…処理データが30万件あるものを今回は作っていまして処理速度等は常に考えてはいました。
    これから勉強して対応できるようにしてみます。
    ありがとうございました。

    キャンセル

0

AutoFillterのエラーについて

こちらの環境(Win7/Office2010)で実行してみたところ、AutoFillterはアクティブシートでなくても問題なく動作しました。
(ちなみにCriteria1を直接セルで指定しても、そのセルの値で正しく絞り込んでくれました。)

ただ、AutoFillterで作成されたフィルター列が8列もないのに8列目を指定して絞り込もうとした際に、AutoFillterのエラーが発生しました。
たまたまデバッグしながら動作させていて、関係ないエクセルファイルをアクティブにしてしまった時に発生したのですが、似たような状況、もしくはそのようなフィルターになるファイルを対象に指定していないでしょうか?

その他のアドバイス

以下はコードの書き方に対するアドバイスです。

アクティブシートに対する操作は対象シートを明記しなくても操作が可能です。
例:アクティブシート(Sheet1)のC2セルを取得する場合、以下のように参照できる。

sValue = Cells(2, 3)

ですが、複数のシートを扱うコードを書く場合、面倒でもどのシートに対する操作になるのかを明示したほうが、結果的に見やすくなり、処理も追いやすくなります。
また処理途中でのユーザー操作によって意図しない動作になる事故も防げます。

例:アクティブシート(Sheet1)のC2セルを取得する場合でも、以下のように対象シートを明示して参照する。

sValue = Sheet1.Cells(2, 3)

同じくコードを見やすくするテクニックとして、面倒でも処理内容をコメントとして記述する、というものがあります。
書き込みすぎる必要はありませんが、「この処理はこんな目的で記述している」ということがわかることで、プログラムを追う際に整理しながら調査を進めることができます。
これにより、
・この処理はコピー元セルのA1セルの値を取得するものなので、A1には"AAA"が入力されているから、取得値は"AAA"になるはず。
といったことがわかりやすくなり、デバッグ中に意図しない("AAA"ではない)値となった時に、「何かがおかしい」と気が付けるようになります。

コードがうまく動かないときにこそ、面倒くさがらずにコメントを書いてみてください。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/06/23 15:07

    JAWAさん、前回に引き続き本当にありがとうございます。
    今回はあまりはまることなくほぼ自己解決することが出来ました。
    今回かなりスムーズに進めることができたのは、
    前回ご教授いただいたことが大きいと感じています。

    AutoFillterについて
    その部分に関しましては、指定データをActivateしたことによって解決しました。
    環境の違いなのでしょうか…(win10/office2013)動いているので問題はないでしょうがまたこのような事態にならないためにも検証は行ってみます。

    アドバイスについて
    このようなことまでアドバイスしていただき本当に感謝しています。
    確かにソースを書いていてわけがわからなくなることは多々ありますので
    コメントアウトする事は念頭に置いてこれから進めていこうと思います。

    今後も自己解決できなくなったときには頼らせていただければなと思います。
    本当にありがとうございます。

    キャンセル

  • 2016/06/23 15:51

    解決したようで何よりです。

    エラーの発生についてもう少しわかったことがありましたので補足させて下さい。

    おそらく今回のエラー発生個所は
    ```
    Selection.AutoFilter
    ```
    だったのではないかと思います。

    シートを指定せず、選択位置に対してAutoFilterをかける記述になっています。

    このため、意図せず他のシートがアクティブな状態でこのマクロが動作すると、その時アクティブなシートの選択されている位置に対してAutoFilterをかけることになってしまいます。

    例えば空のシートでAutoFilterをかけようとしてもエラーが発生してしまいますが、これと同様に選択されているセルがオートフィルターをかけられないような位置だった場合にエラーが発生していたのではないかと思われます。

    今回マクロではcsvファイルをオープンした直後で、セル位置も設定する前の処理ですので、通常であれば開いたCSVファイルのA1セルが選択されており、それに対してAutoFilterをかける処理を期待していたと思います。
    そうであれば、
    ```
    Selection.AutoFilter
    ```
    ではなく
    ```
    openbooksheet.Range("A1").AutoFilter
    ```
    としたほうがよかったのかもしれません。


    ちなみにその直後にしっかりシートとセル位置を指定したAutoFilterの記述
    ```
    openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br
    ```
    があります。

    こちらは「絞り込む操作」として記述されたのかもしれませんが、こちらだけでもAutoFilterをかけたうえで絞り込みまでしてくれます。

    事前に
    ```
    Selection.AutoFilter
    ```
    をする必要はないと思います。


    長くなってしまいましたが、要点としては
    ・対象シートを明示したほうが事故が起きにくい
    ・openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br だけでも絞り込みできる
    です。

    キャンセル

  • 2016/06/23 16:25

    なるほど…一応今回のマクロは一度クロージングしてしまったのですが、
    今から機能追加をしますので、一緒に修正をかけてみます。
    その機能追加に関しましても、調べてはみたのですが考えが至らず…
    お力をお借り出来たら嬉しく思います。
    よろしくお願いします。

    キャンセル

同じタグがついた質問を見る

  • VBA

    2371questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1956questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • マクロ

    290questions

    定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。