こんにちは、ExcelシートからCSVファイルを出力するマクロを作ってみました。
問題なく動きますが、これはシート1つに対して起動します。現在は、各シートにボタンを作り、そのボタンを押すとcsvExportを読みだしています。
やりたいのは、シートが約20枚あり、1枚目のシートに「一括出力」ボタンを作り、2~18番目のシートを対象にして、csvExportを実行させたいですが、VBAが全く分からなくてすごく困っています。2番から最後のシートまで繰り返し、19番と20番シート意外であれば、csvExportマクロを実行してCSVファイルを一括出力したいです。
一括出力するためのcsvExportAllをどのように書けばよろしいですか?こんな感じで書いてみたんですが、全然ダメでした。
何かヒントあれば、ぜひ教えてください。
VBA
1Sub csvExportAll() 2 3 Dim sht As Worksheet 4 Dim ws_cnt As Integer 5 Dim I As Integer 6 ws_cnt = ActiveWorkbook.Worksheets.Count 7 8 For I = 2 To ws_cnt 9 If ws_cnt <> 19 Or ws_cnt <> 20 Then 10 Module1.csvExport 11 End If 12 Next I 13 14End Sub
これは、参考:CSVファイルを出力するVBA を真似して書いたcsvExportです。
VBA
1Option Explicit 2 3Sub csvExport() 4 5 'CONST値の設定 6 Dim initYear As String 7 Dim userName As String 8 Dim userIdx As String 9 10 initYear = Sheets(2).Range("D22").Value '学年度 11 userIdx = Sheets(2).Range("D23").Value '契約ID 12 userName = Sheets(2).Range("D24").Value '契約者名 13 14 Dim csv As String ' CSV に書き込む全データ 15 Dim line As String ' 1 行分のデータ 16 Dim sheetName As String ' シート名 17 18 ' CSV のシートを選択 19 Dim ws As Worksheet 20 Set ws = ActiveSheet ' 選択しているシート 21 sheetName = ws.Name & "マスタ" 'シート名取得 22 23 ' データの範囲を選択 24 Dim region As Range 25 Set region = ws.Range("B4").CurrentRegion ' セル「A1」を含むデータの範囲を取得 26 27 ' 見出し行を取り除く 28 Set region = region.Offset(1, 0) ' 範囲を 1 行下にずらす 29 Set region = region.Resize(RowSize:=region.Rows.Count - 1) ' 範囲を 1 行分縮める 30 31 ' 区切り文字の選択 32 Dim delimiter As String 33 delimiter = "," ' カンマ区切り 34 35 Dim row As Range 36 For Each row In region.Rows ' 行のループ 37 38 line = "" 39 Dim cell As Range 40 For Each cell In row.Columns ' 列のループ 41 42 ' カンマ区切りで結合 43 Dim item As Variant 44 45 item = """" & cell.Value & """" 46 47 If line = "" Then 48 line = item 49 Else 50 line = line & delimiter & item 51 End If 52 53 Next 54 55 ' 行を結合 56 If csv = "" Then 57 csv = line 58 Else 59 csv = csv & delimiter & """" & """" & delimiter & """" & """" & vbCrLf & line 60 End If 61 62 Next 63 64 ' 書き込み処理 65 'UTF-8で保存するため、ADODB.Streamを使用する。 66 67 Const adSaveCreateOverWrite = 2 68 Const adTypeBinary = 1 69 Const adTypeText = 2 70 71 Dim adoTemp As Object 72 Set adoTemp = CreateObject("ADODB.Stream") 73 Dim adoUTF8 As Object 74 Set adoUTF8 = CreateObject("ADODB.Stream") 75 76 'ファイル名は、「契約者名」_「年度」_「シート名」マスタ_初期設定.csvとする。 77 Dim initFileName As String 78 initFileName = ThisWorkbook.Path & "\" & userName & "_" & initYear & "学年度_" & sheetName & "_" & "初期設定.csv" 79 80 With adoTemp 81 .Charset = "UTF-8" ' UTF-8 を指定 82 .Open 83 .WriteText """" & sheetName & """" & vbCrLf ' 1行名にシート名を書き込む 84 .WriteText csv ' 2行名から作成した CSV 形式のデータを書き込み 85 .Position = 0 86 .Type = adTypeBinary 87 .Position = 3 88 End With 89 90 With adoUTF8 ' BOM を取り除いて保存 91 .Type = adTypeBinary 92 .Open 93 adoTemp.CopyTo adoUTF8 94 .SaveToFile initFileName, adSaveCreateOverWrite ' CSV ファイルに保存 95 End With 96 97 adoTemp.Close 98 adoUTF8.Close 99 100 Set adoTemp = Nothing 101 Set adoUTF8 = Nothing 102 103End Sub 104
回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。