CSV分割マクロ(ExcelVBA)

ゆーしゃん
2021.11.20
5,064 views

概要

CSVを指定件数毎に分割し、分割CSVファイルを出力する

プログラムを作成した理由

アップロードするサイトが500件以下しかアップを受け付けない仕様の為、
1万行に及ぶCSVファイルを手動で500件毎に分割する必要がある

例)500件分割 / 1万行 = 20ファイル

手作業では10分以上掛かる上にミスも多発…( ﾟДﾟ)
~~というかこんな仕事やりたくないです~~

ソースコード

Option Explicit
'概要：csv分割(ユーザー件数指定)
Sub CSV分割処理()
    
    '変数宣言
    Dim strFileName As String
    Dim strOutFileName As String
    Dim strTitleLine As String
    Dim fileIdx As Integer
    Dim stPos As Long
    
    Dim maxIdx As Integer
    Dim Target_WorkBook As Workbook
    Dim Split_MaxVar As Variant
    Dim Save_FileName As String
    Dim Temp_Str As String
    Dim Wb As Workbook
    
    'ループカウンタ
    Dim i As Long
    
    '初期化
    fileIdx = 1
    stPos = 0
    
    '分割最大件数取得
    Split_MaxVar = InputBox("最大行を入力してください(※100以上)", Default:=500)
    
    '入力値チェック
    '数値チェック
    If Not IsNumeric(Split_MaxVar) Then
        
        MsgBox "数値を入力してね"
        End
        
    '100以上チェック
    ElseIf CInt(Split_MaxVar) < 100 Then
    
        MsgBox "最大行は100以上でセットしてね"
        End
    
    Else
        
        '数値型に変換
        maxIdx = CInt(Split_MaxVar)
    
    End If
    
    'Importファイル選択
    strFileName = OpenWorkBook()
    
    'ファイル名取得_末尾「\」以降を取得
    Save_FileName = Replace(strFileName, Get_LastMartDelete(strFileName, "\"), "")
    
    'ファイル名取得_最初「\」除外
    Save_FileName = Replace(Save_FileName, "\", "", 1, 1)
    
    '指定ファイルが既に開かれている場合、中止
    For Each Wb In Workbooks
        If Wb.Name = Save_FileName Then
            MsgBox "指定ファイルが既に開かれています。閉じてから実行してください。"
            '処理終了
            End
        End If
    Next
    
    'ファイル名取得_拡張子除外
    Save_FileName = Get_LastMartDelete(Save_FileName, ".")
    
    '高速化_開始
    With Application
    
        .Calculation = xlCalculationManual   '手動計算に
        .ScreenUpdating = False              '画面描画を停止
        .DisplayStatusBar = True             'ステータスバー表示
        .StatusBar = ""                      'ステータスバー文言初期化
    
    End With
    
    '分割元_CSVファイルのオープン
    Open strFileName For Input As #1
        
        '分割元ファイルが終端到達するまでループ
        Do While Not EOF(1)
            
            '項目名読み込み
            If fileIdx = 1 And stPos = 0 Then
                Line Input #1, strTitleLine
            End If
            
            '保存ファイル名
            strOutFileName = Save_FileName &amp; "_" &amp; fileIdx &amp; ".csv"
            
            '保存用_CSVファイルのオープン
            Open strOutFileName For Output As #2
                
                '項目名追記
                Print #2, strTitleLine
                
                '分割記載ループ
                For i = stPos To stPos + maxIdx - 1
                    
                    'ファイル終端到達時、分割終了
                    If EOF(1) Then
                        Exit For
                    End If
                    
                    '分割元から1行読み込み
                    Line Input #1, Temp_Str
                    
                    '読み込み1行を追記
                    Print #2, Temp_Str
                    
                Next i
                
            Close #2
            
            'ファイル保存番号更新
            fileIdx = fileIdx + 1
            
            '読み込み行数更新
            stPos = stPos + maxIdx
            
        Loop
    
    Close
    
    '設定初期化
    Call Initialization
            
    '完了メッセージ
    MsgBox "完了致しました！"
        
End Sub
'概要：ユーザー指定ファイル名を返却
'第一引数：ワークブック
'返却値：指定ブックの格納フルパス
Private Function OpenWorkBook() As String
    
    '変数定義
    Dim varFileName As Variant
    Dim OpenPass As String
    Dim OpenFileName As String
  
    'ダイアログを表示(※読み取り専用)
    varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv*", _
                                              Title:="分割CSVファイルを選択してください。")
                                              
    'キャンセルチェック
    '※キャンセル時_文字型「False」が格納される)
    If varFileName = "False" Then
    
        MsgBox "キャンセルされました。"
        
        '設定初期化
        Call Initialization
        
        '処理終了
        End
        
    End If
    '返却値
    OpenWorkBook = varFileName
End Function
'概要：末尾記号以降の文言取得
'第一引数：ファイル名
'第二引数：末尾記号
'返却値：
'【拡張子有り】指定末尾記号以降の文言
'【拡張子無し】空白
Private Function Get_LastMartDelete(ByVal Target_Str As String, Target_Mark) As String
    
    '変数定義
    Dim Reverse_Str As String
    Dim Result_Str As String
    
    '拡張子が存在する場合対応
    If InStr(Target_Str, Target_Mark) Then
    
        '左右反転ファイル名
        Reverse_Str = StrReverse(Target_Str)
        
        '拡張子除外ファイル名取得
        Result_Str = Mid(Reverse_Str, InStr(Reverse_Str, Target_Mark) + 1, Len(Reverse_Str))
        
        '左右反転を戻す
        Result_Str = StrReverse(Result_Str)
        
        '返却値
        Get_LastMartDelete = Result_Str
    
    Else
        
        '返却値：空白
        Get_LastMartDelete = ""
        
    End If
           
End Function
'概要：設定初期化
Private Sub Initialization()
    
    With Application
    
        .StatusBar = ""                       'ステータスバー文言初期化
        .DisplayAlerts = True                 '警告ON
        .ScreenUpdating = True                '画面描画を開始
        .Calculation = xlCalculationAutomatic '自動計算に
    
    End With
    
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

Option Explicit

'概要：csv分割(ユーザー件数指定)

Sub CSV分割処理()

'変数宣言

Dim strFileName As String

Dim strOutFileName As String

Dim strTitleLine As String

Dim fileIdx As Integer

Dim stPos As Long

Dim maxIdx As Integer

Dim Target_WorkBook As Workbook

Dim Split_MaxVar As Variant

Dim Save_FileName As String

Dim Temp_Str As String

Dim Wb As Workbook

'ループカウンタ

Dim i As Long

'初期化

fileIdx = 1

stPos = 0

'分割最大件数取得

Split_MaxVar = InputBox("最大行を入力してください(※100以上)", Default:=500)

'入力値チェック

'数値チェック

If Not IsNumeric(Split_MaxVar) Then

MsgBox "数値を入力してね"

End

'100以上チェック

ElseIf CInt(Split_MaxVar) < 100 Then

MsgBox "最大行は100以上でセットしてね"

End

Else

'数値型に変換

maxIdx = CInt(Split_MaxVar)

End If

'Importファイル選択

strFileName = OpenWorkBook()

'ファイル名取得_末尾「\」以降を取得

Save_FileName = Replace(strFileName, Get_LastMartDelete(strFileName, "\"), "")

'ファイル名取得_最初「\」除外

Save_FileName = Replace(Save_FileName, "\", "", 1, 1)

'指定ファイルが既に開かれている場合、中止

For Each Wb In Workbooks

If Wb.Name = Save_FileName Then

MsgBox "指定ファイルが既に開かれています。閉じてから実行してください。"

'処理終了

End

End If

'ファイル名取得_拡張子除外

Save_FileName = Get_LastMartDelete(Save_FileName, ".")

'高速化_開始

With Application

.Calculation = xlCalculationManual '手動計算に

.ScreenUpdating = False '画面描画を停止

.DisplayStatusBar = True 'ステータスバー表示

.StatusBar = "" 'ステータスバー文言初期化

End With

'分割元_CSVファイルのオープン

Open strFileName For Input As #1

'分割元ファイルが終端到達するまでループ

Do While Not EOF(1)

'項目名読み込み

If fileIdx = 1 And stPos = 0 Then

Line Input #1, strTitleLine

End If

'保存ファイル名

strOutFileName = Save_FileName & "_" & fileIdx & ".csv"

'保存用_CSVファイルのオープン

Open strOutFileName For Output As #2

'項目名追記

Print #2, strTitleLine

'分割記載ループ

For i = stPos To stPos + maxIdx - 1

'ファイル終端到達時、分割終了

If EOF(1) Then

Exit For

End If

'分割元から1行読み込み

Line Input #1, Temp_Str

'読み込み1行を追記

Print #2, Temp_Str

Next i

Close #2

'ファイル保存番号更新

fileIdx = fileIdx + 1

'読み込み行数更新

stPos = stPos + maxIdx

Loop

'設定初期化

Call Initialization

'完了メッセージ

MsgBox "完了致しました！"

End Sub

'概要：ユーザー指定ファイル名を返却

'第一引数：ワークブック

'返却値：指定ブックの格納フルパス

Private Function OpenWorkBook() As String

'変数定義

Dim varFileName As Variant

Dim OpenPass As String

Dim OpenFileName As String

'ダイアログを表示(※読み取り専用)

varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv*", _

Title:="分割CSVファイルを選択してください。")

'キャンセルチェック

'※キャンセル時_文字型「False」が格納される)

If varFileName = "False" Then

MsgBox "キャンセルされました。"

'設定初期化

Call Initialization

'処理終了

End

End If

'返却値

OpenWorkBook = varFileName

End Function

'概要：末尾記号以降の文言取得

'第一引数：ファイル名

'第二引数：末尾記号

'返却値：

'【拡張子有り】指定末尾記号以降の文言

'【拡張子無し】空白

Private Function Get_LastMartDelete(ByVal Target_Str As String, Target_Mark) As String

'変数定義

Dim Reverse_Str As String

Dim Result_Str As String

'拡張子が存在する場合対応

If InStr(Target_Str, Target_Mark) Then

'左右反転ファイル名

Reverse_Str = StrReverse(Target_Str)

'拡張子除外ファイル名取得

Result_Str = Mid(Reverse_Str, InStr(Reverse_Str, Target_Mark) + 1, Len(Reverse_Str))

'左右反転を戻す

Result_Str = StrReverse(Result_Str)

'返却値

Get_LastMartDelete = Result_Str

Else

'返却値：空白

Get_LastMartDelete = ""

End If

End Function

'概要：設定初期化

Private Sub Initialization()

With Application

.StatusBar = "" 'ステータスバー文言初期化

.DisplayAlerts = True '警告ON

.ScreenUpdating = True '画面描画を開始

.Calculation = xlCalculationAutomatic '自動計算に

End With

End Sub

実行内容

「CSV分割処理」マクロを実行する

件数確定後、「OK」を押して実行する

分割対象CSVを選択する

感想

私がマクロ作成するまで、
5年以上誰一人「自動化しよう」とならずに黙々と手作業で分割していたらしいです…
恐ろしい…(||ﾟДﾟ)

編集履歴

2021/11/20　新規作成
2022/08/18　オススメ記事タグを追加

CSV分割マクロ(ExcelVBA)

概要

プログラムを作成した理由

ソースコード

実行内容

感想

編集履歴

関連記事一覧

環境依存文字チェック(ExcelVBA)

エラー値チェック(ExcelVBA)

リストに基づいた記号置換(ExcelVBA)

カンマ区切り文言をユーザー関数で分割(ExcelVBA)

Excelアドイン(マクロ)をリボンに登録(ExcelVBA)

スプレッドシートからSlackチャンネル/DM通知(GAS)

CSV分割マクロ(ExcelVBA)

Slack通知後、スレッドに連投(JavaScript)

【Twitter_bot】検索ワードでの「いいね」昇順ツイート(Python)

チェックボックス選択肢に基くフィールド活性/非活性/必須化(kintone×JavaScript)

スプレッドシートからGmail下書き作成(GAS)

起動中のメモ帳を自動保存(Python)

エラー値チェック(ExcelVBA)

kintoneレコード保存時、複数人にslack_DM送信(kintone×JavaScript)