VBAツール：【Excel】CSVを取り込んで重複行削除・加工し、CSVで出力するツール

by chasou_tech · 公開済み 2024年3月15日 · 更新済み 2024年3月17日

１．ツールの内容

CSV取込み→CSVデータの重複行を削除→不要データを削除→並び替え→CSVで出力
という感じのツールを作りました。
CSV取込み、重複削除、フィルタリング、並び替え、CSV出力など様々な機能を組み合わせているので、何かしらのツールを作るときに各機能部分をコピペすれば役立つと思います。

やること

元のCSVを取り込んだものです。説明しやすいように網掛けしてあります。
黄色と水色が重複しているレコード。重複行は1行にまとめる。
黄色のレコードのように、「利用フラグ」(F列)に「1」が立っているものを残し、空白の方を削除する。

２．ツールのトップ画面

　Excelの見た目はこんな感じです。

・使い方

(1)「取込CSVファイル」と「出力先フォルダ」と「出力ファイル名」を指定する。
(2)「実行」ボタンを押す。
(3)指定した「出力先フォルダ」に保存されます。

・シート名

以下の2つです。
(1)メイン画面：ユーザが操作する画面です。
(2)加工データ：データを取り込んで加工するシートです。空のシートを作っておきます。

３．サンプルコード

VBAをコピペして、「実行」ボタンで「実行Main」を呼び出せばツールは動きます。

Option Explicit
'************************************'
'Main'
'************************************'
Sub 実行Main()
    Dim CSVPath As String
    Dim OutputPath As String

    If MsgBox("実行しますか？", vbYesNo) = vbYes Then
        
        '各パスの取得'
        CSVPath = Worksheets("メイン画面").Range("C4")
        OutputPath = Worksheets("メイン画面").Range("C6") & "\" & Worksheets("メイン画面").Range("C8")
        '"
        Call データクリア
    
        Call CSV取込み(CSVPath)
        
        Call データ加工
        
        Call CSV出力(OutputPath)
        
        MsgBox "完了しました。"
    Else
        MsgBox "実行をキャンセルしました。"
    End If

End Sub

'************************************'
'CSVのパス取得'
'************************************'
Sub CSVのパス取得()
    Dim CSVPath As String
    
    CSVPath = Application.GetOpenFilename("CSVファイル(*.csv),*.csv", 1, "CSVファイルを選択してください", , False)
    '最後の「MultiSelect」をFalseにすることで単独ファイルの選択になります。何も書かない場合もデフォルトでFalseになります。'
    
    If CSVPath <> "False" Then
        Range("C4") = CSVPath
    End If
End Sub
'************************************'
'出力ファイルのフォルダーの指定'
'************************************'
Sub フォルダーの指定()
    Dim xF As FileDialog
    Dim SelectFolder As String
    
    Set xF = Application.FileDialog(msoFileDialogFolderPicker)
    
    With xF
        '//最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。'
        .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop")
 
        '//ダイアログの左上に出てくるタイトル名'
        .Title = "フォルダの指定"
         .AllowMultiSelect = False
 
        If .Show = True Then 'ダイアログを開く'
            SelectFolder = .SelectedItems(1) '指定したフォルダを返す'
        End If
    
    End With
    
    If SelectFolder <> "False" Then
        Range("C6") = SelectFolder
    End If
    
    
    Set xF = Nothing
End Sub
'************************************'
'CSVを取り込むシートのデータをクリアする'
'************************************'
Function データクリア()

    Dim LastRow As Long
    Dim LastColumn As Long
    
    With Sheets("加工データ")
        .Range("1:1").AutoFilter
        
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column

        .Range(.Range("B1"), .Cells(LastRow, LastColumn)).ClearContents

    End With

End Function

'************************************'
'//CSVデータの取込み'
'************************************'
Function CSV取込み(CSVPath As String)
    Dim buf As String
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim EachRow_Array As Variant
    Dim i As Long
    Dim j As Long
    
    
    LastRow = getLastRow(CSVPath)
    LastColumn = getLastColumn(CSVPath)

    ReDim NumColumn_Array(LastRow, LastColumn)
    
    Open CSVPath For Input As #1
        Do Until EOF(1)
            Line Input #1, buf
            EachRow_Array = Split(buf, ",")
            For j = 0 To UBound(EachRow_Array)
                NumColumn_Array(i, j) = EachRow_Array(j)
            Next j
            i = i + 1
        Loop
    Close #1
    
    With Sheets("加工データ")
        .Range("B1").Resize(LastRow + 1, LastColumn + 1) = NumColumn_Array ''1回だけ代入
        
        '重複チェック用の数式をコピペ'
        .Range("A1") = "重複チェック"
        .Range(.Cells(2, 1), .Cells(LastRow + 1, 1)).Formula = "=COUNTIF(B:B,B2)"
    
    End With
    
End Function

'************************************'
'取込むCSVファイルの行数を取得'
'************************************'
Function getLastRow(CSVPath As String) As Long
    Dim buf As String
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    With FSO.OpenTextFile(CSVPath, 1)
        buf = .ReadAll
        .Close
    End With
    
    getLastRow = UBound(Split(buf, vbCrLf)) - 1
    
    Set FSO = Nothing
    
End Function

'************************************'
'取込むCSVファイルの列数を取得'
'************************************'
Function getLastColumn(CSVPath As String) As Long
    Dim buf As String
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    With FSO.OpenTextFile(CSVPath, 1)
        buf = .ReadLine
        .Close
    End With
    
    getLastColumn = UBound(Split(buf, ",")) + 1
    
    Set FSO = Nothing
    
End Function

'************************************'
'//出力CSV用のデータに加工'
'************************************'
Function データ加工()
    
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim targetRange As Range
    Dim i As Long
    Dim j As Long
    
    Sheets("加工データ").Range("A1").CurrentRegion.AutoFilter
    
    '//重複行削除'
    With Sheets("加工データ")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        
        '//データ型の指定'
        .Range(.Cells(2, 1), .Cells(LastRow, 5)).NumberFormatLocal = "G/標準"
        .Range(.Cells(2, 5), .Cells(LastRow, 5)).NumberFormatLocal = "0"
        .Range(.Cells(2, 5), .Cells(LastRow, 6)).NumberFormatLocal = "0"

        '//重複行の削除'
        '重複をチェックするカラムはArrayで設定'
        .Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
        
    End With

    '//不要データをフィルターリングして削除'
    With Sheets("加工データ").Range("A1").CurrentRegion
        .AutoFilter 1, ">1"
        .AutoFilter 6, ""
        
        Set targetRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        
        targetRange.Delete shift:=xlUp
        
        .AutoFilter
        
        .Range("A1").EntireColumn.Delete
    End With
    
    '//対象カラムを降順で並び替え'
    With Sheets("加工データ")
        .Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Sort Key1:=.Range("F1"), Order1:=xlDescending, Header:=xlYes
    End With

End Function

'************************************'
'CSVファイルとして出力'
'************************************'
Function CSV出力(OutputPath As String)

    Dim Target As String
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim j As Long
    Dim buf As String
    
    With Sheets("加工データ")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
    End With
    
    Target = OutputPath & Format(Now(), "yyyymmdd") & ".csv"
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8" '出力形式の指定。"Shift-JIS"等'
        .Open
        For i = 1 To LastRow
            buf = ""
            For j = 1 To LastColumn
                buf = buf & Sheets("加工データ").Cells(i, j) & ","
            Next j
            .WriteText Left(buf, Len(buf) - 1), 1
        Next i
        .SaveToFile Target, 2
        .Close
    End With
                  
End Function

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

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

Option Explicit

'************************************'

'Main'

'************************************'

Sub 実行Main()

Dim CSVPath As String

Dim OutputPath As String

If MsgBox("実行しますか？", vbYesNo) = vbYes Then

'各パスの取得'

CSVPath = Worksheets("メイン画面").Range("C4")

OutputPath = Worksheets("メイン画面").Range("C6") & "\" & Worksheets("メイン画面").Range("C8")

Call データクリア

Call CSV取込み(CSVPath)

Call データ加工

Call CSV出力(OutputPath)

MsgBox "完了しました。"

Else

MsgBox "実行をキャンセルしました。"

End If

End Sub

'************************************'

'CSVのパス取得'

'************************************'

Sub CSVのパス取得()

Dim CSVPath As String

CSVPath = Application.GetOpenFilename("CSVファイル(*.csv),*.csv", 1, "CSVファイルを選択してください", , False)

'最後の「MultiSelect」をFalseにすることで単独ファイルの選択になります。何も書かない場合もデフォルトでFalseになります。'

If CSVPath <> "False" Then

Range("C4") = CSVPath

End If

End Sub

'************************************'

'出力ファイルのフォルダーの指定'

'************************************'

Sub フォルダーの指定()

Dim xF As FileDialog

Dim SelectFolder As String

Set xF = Application.FileDialog(msoFileDialogFolderPicker)

With xF

'//最初に開く場所(初期フォルダ)の指定。ここではデスクトップにしています。'

.InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop")

'//ダイアログの左上に出てくるタイトル名'

.Title = "フォルダの指定"

.AllowMultiSelect = False

If .Show = True Then 'ダイアログを開く'

SelectFolder = .SelectedItems(1) '指定したフォルダを返す'

End If

End With

If SelectFolder <> "False" Then

Range("C6") = SelectFolder

End If

Set xF = Nothing

End Sub

'************************************'

'CSVを取り込むシートのデータをクリアする'

'************************************'

Function データクリア()

Dim LastRow As Long

Dim LastColumn As Long

With Sheets("加工データ")

.Range("1:1").AutoFilter

LastRow = .Cells(Rows.Count, 1).End(xlUp).Row

LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column

.Range(.Range("B1"), .Cells(LastRow, LastColumn)).ClearContents

End With

End Function

'************************************'

'//CSVデータの取込み'

'************************************'

Function CSV取込み(CSVPath As String)

Dim buf As String

Dim LastRow As Long

Dim LastColumn As Long

Dim EachRow_Array As Variant

Dim i As Long

Dim j As Long

LastRow = getLastRow(CSVPath)

LastColumn = getLastColumn(CSVPath)

ReDim NumColumn_Array(LastRow, LastColumn)

Open CSVPath For Input As #1

Do Until EOF(1)

Line Input #1, buf

EachRow_Array = Split(buf, ",")

For j = 0 To UBound(EachRow_Array)

NumColumn_Array(i, j) = EachRow_Array(j)

Next j

i = i + 1

Loop

Close #1

With Sheets("加工データ")

.Range("B1").Resize(LastRow + 1, LastColumn + 1) = NumColumn_Array ''1回だけ代入

'重複チェック用の数式をコピペ'

.Range("A1") = "重複チェック"

.Range(.Cells(2, 1), .Cells(LastRow + 1, 1)).Formula = "=COUNTIF(B:B,B2)"

End With

End Function

'************************************'

'取込むCSVファイルの行数を取得'

'************************************'

Function getLastRow(CSVPath As String) As Long

Dim buf As String

Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO.OpenTextFile(CSVPath, 1)

buf = .ReadAll

.Close

End With

getLastRow = UBound(Split(buf, vbCrLf)) - 1

Set FSO = Nothing

End Function

'************************************'

'取込むCSVファイルの列数を取得'

'************************************'

Function getLastColumn(CSVPath As String) As Long

Dim buf As String

Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO.OpenTextFile(CSVPath, 1)

buf = .ReadLine

.Close

End With

getLastColumn = UBound(Split(buf, ",")) + 1

Set FSO = Nothing

End Function

'************************************'

'//出力CSV用のデータに加工'

'************************************'

Function データ加工()

Dim LastRow As Long

Dim LastColumn As Long

Dim targetRange As Range

Dim i As Long

Dim j As Long

Sheets("加工データ").Range("A1").CurrentRegion.AutoFilter

'//重複行削除'

With Sheets("加工データ")

LastRow = .Cells(Rows.Count, 1).End(xlUp).Row

LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column

'//データ型の指定'

.Range(.Cells(2, 1), .Cells(LastRow, 5)).NumberFormatLocal = "G/標準"

.Range(.Cells(2, 5), .Cells(LastRow, 5)).NumberFormatLocal = "0"

.Range(.Cells(2, 5), .Cells(LastRow, 6)).NumberFormatLocal = "0"

'//重複行の削除'

'重複をチェックするカラムはArrayで設定'

.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes

End With

'//不要データをフィルターリングして削除'

With Sheets("加工データ").Range("A1").CurrentRegion

.AutoFilter 1, ">1"

.AutoFilter 6, ""

Set targetRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

targetRange.Delete shift:=xlUp

.AutoFilter

.Range("A1").EntireColumn.Delete

End With

'//対象カラムを降順で並び替え'

With Sheets("加工データ")

.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Sort Key1:=.Range("F1"), Order1:=xlDescending, Header:=xlYes

End With

End Function

'************************************'

'CSVファイルとして出力'

'************************************'

Function CSV出力(OutputPath As String)

Dim Target As String

Dim LastRow As Long

Dim LastColumn As Long

Dim i As Long

Dim j As Long

Dim buf As String

With Sheets("加工データ")

LastRow = .Cells(Rows.Count, 1).End(xlUp).Row

LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column

End With

Target = OutputPath & Format(Now(), "yyyymmdd") & ".csv"

With CreateObject("ADODB.Stream")

.Charset = "UTF-8" '出力形式の指定。"Shift-JIS"等'

.Open

For i = 1 To LastRow

buf = ""

For j = 1 To LastColumn

buf = buf & Sheets("加工データ").Cells(i, j) & ","

Next j

.WriteText Left(buf, Len(buf) - 1), 1

Next i

.SaveToFile Target, 2

.Close

End With

End Function

VBAツール：【Excel】CSVを取り込んで重複行削除・加工し、CSVで出力するツール

１．ツールの内容

やること

２．ツールのトップ画面

・使い方

・シート名

３．サンプルコード

関連記事

VBA：取り込むCSVの行数と列数を取得する方法

VBA：Excelの重複行を削除する方法

VBA：Excelでフィルターをかけたデータを削除する方法

VBA：ExcelのデータをCSVで出力する方法

おすすめ

カテゴリー

プロフィール

Facebook

チャイ専門店　茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

VBAツール：【Excel】CSVを取り込んで重複行削除・加工し、CSVで出力するツール

１．ツールの内容

やること

２．ツールのトップ画面

・使い方

・シート名

３．サンプルコード

関連記事

VBA：取り込むCSVの行数と列数を取得する方法

VBA：Excelの重複行を削除する方法

VBA：Excelでフィルターをかけたデータを削除する方法

VBA：ExcelのデータをCSVで出力する方法

おすすめ

VBA：ファイルの削除「Killステートメント」

VBA：【FSO】フォルダーのコピー「CopyFolder」(FileSystemObject)

VBAツール：【Excel】複数ファイルーファイル毎一括圧縮ツール（Windows標準 zip圧縮）

カテゴリー

プロフィール

Facebook

チャイ専門店 茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

チャイ専門店　茶窓