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

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

ただいまの
回答率

87.59%

ExcelのVBAモジュールを複数のシートに一括処理させたいです。

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 1,998

score 34

こんにちは、ExcelシートからCSVファイルを出力するマクロを作ってみました。

問題なく動きますが、これはシート1つに対して起動します。現在は、各シートにボタンを作り、そのボタンを押すとcsvExportを読みだしています。

やりたいのは、シートが約20枚あり、1枚目のシートに「一括出力」ボタンを作り、2~18番目のシートを対象にして、csvExportを実行させたいですが、VBAが全く分からなくてすごく困っています。2番から最後のシートまで繰り返し、19番と20番シート意外であれば、csvExportマクロを実行してCSVファイルを一括出力したいです。
一括出力するためのcsvExportAllをどのように書けばよろしいですか?こんな感じで書いてみたんですが、全然ダメでした。
何かヒントあれば、ぜひ教えてください。

Sub csvExportAll()

    Dim sht As Worksheet
    Dim ws_cnt As Integer
    Dim I As Integer
    ws_cnt = ActiveWorkbook.Worksheets.Count

    For I = 2 To ws_cnt
       If ws_cnt <> 19 Or ws_cnt <> 20 Then
         Module1.csvExport
       End If
    Next I

End Sub

これは、参考:CSVファイルを出力するVBA を真似して書いたcsvExportです。

Option Explicit

Sub csvExport()

    'CONST値の設定
    Dim initYear As String
    Dim userName As String
    Dim userIdx As String

    initYear = Sheets(2).Range("D22").Value    '学年度
    userIdx = Sheets(2).Range("D23").Value   '契約ID
    userName = Sheets(2).Range("D24").Value  '契約者名

    Dim csv As String  ' CSV に書き込む全データ
    Dim line As String ' 1 行分のデータ
    Dim sheetName As String ' シート名

    ' CSV のシートを選択
    Dim ws As Worksheet
    Set ws = ActiveSheet      ' 選択しているシート
    sheetName = ws.Name & "マスタ"       'シート名取得

    ' データの範囲を選択
    Dim region As Range
    Set region = ws.Range("B4").CurrentRegion ' セル「A1」を含むデータの範囲を取得

    ' 見出し行を取り除く
    Set region = region.Offset(1, 0)                           ' 範囲を 1 行下にずらす
    Set region = region.Resize(RowSize:=region.Rows.Count - 1) ' 範囲を 1 行分縮める

    ' 区切り文字の選択
    Dim delimiter As String
    delimiter = ","   ' カンマ区切り

    Dim row As Range
    For Each row In region.Rows ' 行のループ

        line = ""
        Dim cell As Range
        For Each cell In row.Columns ' 列のループ

            ' カンマ区切りで結合
            Dim item As Variant

                item = """" & cell.Value & """"

            If line = "" Then
                line = item
            Else
                line = line & delimiter & item
            End If

        Next

        ' 行を結合
        If csv = "" Then
            csv = line
        Else
            csv = csv & delimiter & """" & """" & delimiter & """" & """" & vbCrLf & line
        End If

    Next

    ' 書き込み処理
    'UTF-8で保存するため、ADODB.Streamを使用する。

    Const adSaveCreateOverWrite = 2
    Const adTypeBinary = 1
    Const adTypeText = 2

    Dim adoTemp As Object
    Set adoTemp = CreateObject("ADODB.Stream")
    Dim adoUTF8 As Object
    Set adoUTF8 = CreateObject("ADODB.Stream")

    'ファイル名は、「契約者名」_「年度」_「シート名」マスタ_初期設定.csvとする。
    Dim initFileName As String
    initFileName = ThisWorkbook.Path & "\" & userName & "_" & initYear & "学年度_" & sheetName & "_" & "初期設定.csv"

    With adoTemp
      .Charset = "UTF-8" ' UTF-8 を指定
      .Open
      .WriteText """" & sheetName & """" & vbCrLf      ' 1行名にシート名を書き込む
      .WriteText csv ' 2行名から作成した CSV 形式のデータを書き込み
      .Position = 0
      .Type = adTypeBinary
      .Position = 3
    End With

    With adoUTF8 ' BOM を取り除いて保存
      .Type = adTypeBinary
      .Open
      adoTemp.CopyTo adoUTF8
      .SaveToFile initFileName, adSaveCreateOverWrite ' CSV ファイルに保存
    End With

    adoTemp.Close
    adoUTF8.Close

    Set adoTemp = Nothing
    Set adoUTF8 = Nothing

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

回答 1

check解決した方法

0

何とか自分で解決できました。
出力したいシートの見出し色を赤(シート.Tab.ColorIndex = 3)にして、赤のシートだけ処理するようにしました。For文でSheets番号を増やしながら、Activate(シート選択)することで動きました。

Sub csvExportAll()

    Dim ws As Worksheet
    Dim ws_cnt As Integer
    Dim I As Integer
    Dim returlvar As Integer

    ws_cnt = ActiveWorkbook.Worksheets.Count


    returlvar = MsgBox("顧客IDと学年度を必ず確認してから実行してください、実行しても大丈夫ですか?", vbYesNo)

    If returlvar = 6 Then

        For I = 2 To ws_cnt

            Set ws = Sheets(I)
            ws.Activate

            If ws.Tab.ColorIndex = 3 Then

                Module1.csvExport

            End If

        Next I

        Set ws = Sheets(2)
        ws.Activate

        MsgBox "CSVファイル出力に成功しました!"

    Else

        MsgBox "CSVファイル出力をキャンセルしました。"

    End If

End Sub

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

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

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

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