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

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

ただいまの
回答率

87.49%

VBAのオートフィルターを使ってCSV出力を行いたい

受付中

回答 3

投稿 編集

  • 評価
  • クリップ 1
  • VIEW 2,188

score 0

前提・実現したいこと

VBAを利用してExcelの値をCSVに出力するプログラムを作成しています。
オートフィルターを利用してB列の絞込を行いながら順番に出力していきたいです。

例えば下記のような表があったときは列2の情報(東京都・愛知県・大阪府)で絞込を順に行い、別々のCSVとしてその行の情報を出力したいと思っています。

列1 列2 列3 列4 列5
1 東京都 Aさん 23歳
2 愛知県 Bさん 53歳
3 東京都 Cさん 29歳
4 大阪府 Dさん 31歳
5 愛知県 Eさん 48歳
6 大阪府 Fさん 12歳

実現イメージ

東京都.csv

列1 列2 列3 列4 列5
1 東京都 Aさん 23歳
3 東京都 Cさん 29歳

愛知県.csv

列1 列2 列3 列4 列5
2 愛知県 Bさん 53歳
5 愛知県 Eさん 48歳

大阪府.csv

列1 列2 列3 列4 列5
4 大阪府 Dさん 31歳
6 大阪府 Fさん 12歳

発生している問題・エラーメッセージ

実際にコードを書いて出力したところ、各県の名称のファイルが出力されたものの、セルの絞込がクリアできていないのか、

東京都⇒東京都のみのデータ(想定通り)
愛知県⇒東京都と愛知県のデータ(想定通りではない)
大阪府⇒東京都と愛知県と大阪府のデータ(想定通りではない)

上記のように出力されてしまいます。

セルのクリアがうまくいっていないか、検索で変数を入れるところがうまく実装できていないかと思うのですが、VBAは初心者でありよくわからなかったので、皆様のお力をお借りしたいと思っています。

よろしくお願いいたします。

該当のソースコード

      Dim cmax
      Dim csvFile As String
      Dim i As Integer

      SaveDir = ThisWorkbook.Path

      'B列の最終行の数を取得
      cmax = Worksheets("active").Range("B65536").End(xlUp).row



      '最終行まで繰り返す
      For i = 2 To cmax

            Dim atai As String
            'ataiにフィルターの絞込を行っている単語を入れる
            If atai <> Worksheets("active").Range("B" & i).Value Then
                  atai = Worksheets("active").Range("B" & i).Value
            End If

           '「フィルターの絞込を行っている単語名.csv」の名称のファイルをカレントディレクトリに作成する
            csvFile = SaveDir & "\" & atai & ".csv"

                '高さをカウント
                lngRowMax = Range("$A$" & Rows.Count).End(xlUp).row


                '書き込みを行うファイルを開く
                Open csvFile For Output As #1

                        'フィルターの絞込がされていたら解除する
                        If ActiveSheet.FilterMode = True Then
                        ActiveSheet.ShowAllData
                        End If

                        'ataiの単語でB列のフィルター動作させる
                        ActiveWorkbook.Worksheets("active").Range("A2:E" & cmax).AutoFilter Field:=2, Criteria1:=atai

                        Dim j As Long
                        For j = 1 To 5
                           '1行目の各列のタイトルを書き込む
                           Print #1, ActiveSheet.Cells(1, j).Value&; ",";
                        Next j
                        '改行
                        Print #1, vbCr;

                        Dim c As Long, k As Long

                        For c = 2 To lngRowMax
                            For j = 1 To 5
                                '絞り込んだデータを基にCSV書き込みを行う
                                Print #1, ActiveSheet.Cells(c, j).Value&; ",";
                            Next j
                            '改行
                            Print #1, ActiveSheet.Cells(c, j).Value & vbCr;
                        Next c
                'ファイルを閉じる
                Close #1

     '次の行に行く
      Next i

     'フィルターの絞込を解除する(全件表示)
     If ActiveSheet.FilterMode = True Then
           ActiveSheet.ShowAllData
     End If
  • 気になる質問をクリップする

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

回答 3

0

絞込したい単語選定とオートフィルターしながらCSV作成の2ステップで処理する必要があります。
コードを見直してみましたので、参考にしてください。

Sub hogeCSV()
    Dim csvFile As String
    Dim i As Integer, lngRowMax As Integer

    Dim SaveDir As String
    SaveDir = ThisWorkbook.Path

    '最初に絞込したい単語を選定
    Dim atai As Object
    Set atai = CreateObject("Scripting.Dictionary")

    For i = 2 To Worksheets("active").Range("B65536").End(xlUp).Row
        If Not atai.Exists(Worksheets("active").Range("B" & i).Value) Then
              atai.Add Worksheets("active").Range("B" & i).Value, 0
        End If
    Next i '次の行に行く

    'オートフィルターしながらCSV作成
    Dim v As Variant
    For Each v In atai.Keys
        '「フィルターの絞込を行っている単語名.csv」の名称のファイルをカレントディレクトリに作成する
        csvFile = SaveDir & "\" & v & ".csv"

        '書き込みを行うファイルを開く
        Open csvFile For Output As #1

        'フィルターの絞込がされていたら解除する
        If Worksheets("active").FilterMode = True Then
            Worksheets("active").ShowAllData
        End If

        '単語でB列のフィルター動作させる
        Worksheets("active").Range("A1:E1").AutoFilter Field:=2, Criteria1:=v

        '高さをカウント
        lngRowMax = Worksheets("active").Range("B" & Rows.Count).End(xlUp).Row

        Dim j As Long
        For j = 1 To 5
            '1行目の各列のタイトルを書き込む
            Print #1, Worksheets("active").Cells(1, j).Value&; ",";
        Next j
        '改行
        Print #1, vbCr; '改行コードは vbNewline がよいか。

        Dim c As Long
        For c = 2 To lngRowMax
            For j = 1 To 5
                '絞り込んだデータを基にCSV書き込みを行う
                Print #1, Worksheets("active").Cells(c, j).Value&; ",";
            Next j
            '改行
            Print #1, Worksheets("active").Cells(c, j).Value & vbCr; '改行コードは vbNewline がよいか。
        Next c
        'ファイルを閉じる
        Close #1
    Next v

    'フィルターの絞込を解除する(全件表示)
    If Worksheets("active").FilterMode = True Then
        Worksheets("active").ShowAllData
    End If
End Sub

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

0

Option Explicit

Sub test()
    Dim rngData As Range
    Dim rngList As Range
    Dim rngConditions As Range
    Dim rngResult As Range
    Dim c As Range

    'セル範囲指定
    With ThisWorkbook
        Set rngData = .Worksheets(1).UsedRange
        Set rngList = .Worksheets(2).Range("A1")
        Set rngConditions = Worksheets(2).Range("C1:C2")
        Set rngResult = .Worksheets(3).Range(rngData.Rows(1).Address)
    End With

    '準備
    rngList.Worksheet.Cells.ClearContents
    rngConditions(1).Value = rngData(2).Value
    rngResult.Value = rngData.Rows(1).Value

    '重複のない抽出項目のリスト作成
    With rngData
        Intersect(.Offset(1), .Columns("B")).Copy rngList
    End With
    rngList.CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo

    '項目毎に繰り返し
    For Each c In rngList.CurrentRegion
        '抽出条件設定
        rngConditions(2).Value = c.Value

        '抽出
        rngData.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngConditions, _
            CopyToRange:=rngResult

        'CSVで保存
        rngResult.Worksheet.Copy
        With Workbooks(Workbooks.Count)
            .SaveAs Filename:=ThisWorkbook.Path & "\" & c.Value & ".csv", _
                    FileFormat:=xlCSV
            .Close SaveChanges:=False
        End With
    Next
End Sub

1)フィルターオプションで抽出(別のシートに結果をコピーする機能が内包されている)
2)そのシートを新規ブックにコピー
3)CSV形式で保存

という流れではだめでしょうか?

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

0

オートフィルターされたセルを扱うのは、いろいろと落とし穴がありそうですね。
http://officetanaka.net/excel/vba/tips/tips155.htm
を参考にすると、オートフィルターされている結果を他のシートにコピーするのが1番確実なようです。
作業用のシートとして"作業用"というシートを作成しておきます。
そちらにオートフィルターされている結果をコピーした後、"作業用"シートの内容をCSVに出力します。

Public Sub CSV_WithAutoFilter1()
    Dim maxrow As Long
    Dim maxrow2 As Long
    Dim wrow As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim dicT As Object
    Dim key As Variant
    Dim csvFile As String
    Dim SaveDir As String
    Dim cr As Range
    Dim str As String
    SaveDir = ThisWorkbook.Path
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set ws = Worksheets("active")
    Set ws2 = Worksheets("作業用")
    ws.AutoFilterMode = False                       'オートフィルタ解除
    maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    '都道府県単位のキーを集計
    For wrow = 2 To maxrow
        key = ws.Cells(wrow, "B").Value
        dicT(key) = True
    Next
    '全キー分繰り返す
    For Each key In dicT.keys
        '「フィルターの絞込を行っている単語名.csv」の名称のファイルをカレントディレクトリに作成する
        csvFile = SaveDir & "\" & key & ".csv"
        '書き込みを行うファイルを開く
        Open csvFile For Output As #1
        ws.AutoFilterMode = False
        'オートフィルタ設定
        ws.Range("A1").AutoFilter Field:=2, Criteria1:=key
        ws2.Cells.ClearContents
        ws.Range("A1").CurrentRegion.Copy ws2.Range("A1")
        '表示されている全行を処理する
        maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        For wrow = 1 To maxrow2
            Dim j As Long
            For j = 1 To 5
                str = ws2.Cells(wrow, j).Value
                If j <> 5 Then
                    Print #1, str; ",";
                Else
                    Print #1, str; vbCrLf;
                End If
            Next
        Next
        Close #1
    Next
    ws.AutoFilterMode = False
    MsgBox ("完了")
End Sub

尚、作業用のシートは作りたくないということであれば、こちらの方法もあります。
たまたま、こちらでうまくいっただけで、他の環境で正しく動作するかどうかはわかりませんが、
参考までに。

Public Sub CSV_WithAutoFilter2()
    Dim maxrow As Long
    Dim wrow As Long
    Dim ws As Worksheet
    Dim dicT As Object
    Dim key As Variant
    Dim csvFile As String
    Dim SaveDir As String
    Dim cr As Range
    Dim str As String
    SaveDir = ThisWorkbook.Path
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set ws = Worksheets("active")
    ws.AutoFilterMode = False                       'オートフィルタ解除
    maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    '都道府県単位のキーを集計
    For wrow = 2 To maxrow
        key = ws.Cells(wrow, "B").Value
        dicT(key) = True
    Next
    '全キー分繰り返す
    For Each key In dicT.keys
        '「フィルターの絞込を行っている単語名.csv」の名称のファイルをカレントディレクトリに作成する
        csvFile = SaveDir & "\" & key & ".csv"
        '書き込みを行うファイルを開く
        Open csvFile For Output As #1
        ws.AutoFilterMode = False
        'オートフィルタ設定
        ws.Range("A1").AutoFilter Field:=2, Criteria1:=key
        '表示されている全行を処理する
        For Each cr In ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
            wrow = cr.Row
            Dim j As Long
            For j = 1 To 5
                str = ws.Cells(wrow, j).Value
                If j <> 5 Then
                    Print #1, str; ",";
                Else
                    Print #1, str; vbCrLf;
                End If
            Next
        Next
        Close #1
    Next
    ws.AutoFilterMode = False
    MsgBox ("完了")
End Sub

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

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

  • ただいまの回答率 87.49%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

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