ＶＢＡでExcelのCSVへ分割出力

要件

Excelの整理したデータはでかい場合、何万件で分割出力する

分析

VBAで出力分のデータは別ブックに張り付け、そのままＣＳＶに保存する
入出力イメージ

実装

Sub write2csvSep()

Dim wArr() ' write out csc arry

Dim i As Long
i = 3

'一万件の分で出力
csvSize = 10000

'name prfix
profixN = "来場202207-"


Set toSht = ActiveSheet


'columns number
jj = 1
While toSht.Cells(1, jj) <> ""
 jj = jj + 1
Wend
'項目の数
colSize = jj - 1

'CSVヘッダーは物理名と論理名が２行ある想定、最大200項目想定
Dim hArr(2, 200)

For ih = 1 To 2
 For jh = 1 To colSize
  hArr(ih - 1, jh - 1) = toSht.Cells(ih, jh)
 Next
Next

'ファイルカウント
fcnt = 0
ReDim wArr(csvSize, 200)
ii = 0

Application.DisplayAlerts = False

'３行目からデータ行
While toSht.Cells(ii + 3, 1) <> ""

  For j = 1 To colSize
   wArr(ii - fcnt * csvSize, j - 1) = toSht.Cells(ii + 3, j)
  Next j

  ii = ii + 1

 
  '出力の数になったら、出力する
  If Int(ii / csvSize) * csvSize = ii Then
     fcnt = Int(ii / csvSize)
     Workbooks.Add
     Set wb = ActiveWorkbook
     
     'ファイル名を指定
     fname = "c:\tmp\" & profixN & fcnt & ".csv"
     '文字型にする
　   'NumberFormatLocal = "@"
     wb.ActiveSheet.Cells.Select
     Selection.NumberFormatLocal = "@"

     wb.ActiveSheet.Cells(1, 1).Resize(2, 200) = hArr
     wb.ActiveSheet.Cells(3, 1).Resize(csvSize, 200) = wArr
     
     'FileFormatにUtf8の指定も可能
     wb.SaveAs Filename:=fname, FileFormat:=xlCSV, CreateBackup:=False
     wb.Close
     
     'メモリがリセット
     Erase wArr
     ReDim wArr(csvSize, 200)
  End If
   

 Wend
 
 '最後の部分を出力
 If Int(ii / csvSize) * csvSize <> ii Then
     fcnt = fcnt + 1
     Workbooks.Add
     Set wb = ActiveWorkbook
     fname = "c:\tmp\" & profixN & fcnt & ".csv"
     '文字型にする
　   'NumberFormatLocal = "@"
     wb.ActiveSheet.Cells.Select
     Selection.NumberFormatLocal = "@"

     wb.ActiveSheet.Cells(1, 1).Resize(2, 200) = hArr
     wb.ActiveSheet.Cells(3, 1).Resize(csvSize, 200) = wArr
     wb.SaveAs Filename:=fname, FileFormat:=xlCSV, CreateBackup:=False
     wb.Close
End If

 Application.DisplayAlerts = True
 
  '件数を表示
 
 MsgBox "File " & profixN & "n 件数：" & ii
End Sub