ひできちの楽天ブログ

< 新しい記事

新着記事一覧(全962件)

過去の記事 >

2026/01/19

ExcelシートにCSVファイルを読み込むVBA

テーマ： EXCEL VBAで簡単プログラミング！(55)

カテゴリ：プログラミング

ExcelシートにCSVファイルを読み込むVBA　コードです。
もちろんExcel標準機能で可能なんですが
マウスワンクリックで終わらせたいと思ったので
Copilot AIに実装させました

要件
・UTF8ファイルに対応
・ファイル名、フォルダーパスはアクティブシートのセルの情報を使用する
ファイル名→A1
フォルダーパス→C1

・文字の"00001"が勝手に数字に変換されないこと

出来上がったソースコードは遅いですがちゃんと動作していますな
処理が遅すぎますが
データ量が少量ならば使えると思いますぞ

 ’----------------------------------------------------------------
Sub ImportCSV_UTF8_RFC4180_A8()

Dim folder As String
Dim fname As String
Dim fullpath As String
Dim txt As String
Dim lines() As String
Dim r As Long
Dim cols As Variant
Dim line As Variant
Dim ws As Worksheet

Set ws = ThisWorkbook.ActiveSheet

folder = ws.Range("C1").Value
fname = ws.Range("A1").Value & ".csv"
fullpath = folder & "\" & fname

'--- UTF-8 テキストとして読み込み（ADODB.Stream 使用）---
txt = ReadTextFileUTF8(fullpath)

'ファイルが空 or 読めなかった場合は終了
If Len(txt) = 0 Then Exit Sub

'--- 改行コードを統一 ---
txt = Replace(txt, vbCrLf, vbLf)
txt = Replace(txt, vbCr, vbLf)
lines = Split(txt, vbLf)

'--- A8 から表示 ---
r = 8

For Each line In lines
If Len(line) > 0 Then

cols = ParseCSV(CStr(line))

Dim c As Long
For c = LBound(cols) To UBound(cols)
With ws.Cells(r, c + 1)
.NumberFormat = "@"
.Value = cols(c)
End With
Next

r = r + 1
End If
Next

End Sub

'===========================================================
' UTF-8 テキスト読み込み（ADODB.Stream 使用）
'===========================================================
Function ReadTextFileUTF8(ByVal path As String) As String
Dim stm As Object
Dim txt As String

Set stm = CreateObject("ADODB.Stream")
With stm
.Type = 2                 'text
.Charset = "UTF-8"
.Open
.LoadFromFile path
txt = .ReadText
.Close
End With
ReadTextFileUTF8 = txt
End Function

'===========================================================
' RFC4180 準拠 CSV パーサ（ダブルクォート完全対応）
'===========================================================
Function ParseCSV(ByVal s As String) As Variant
Dim result() As String
Dim buf As String
Dim i As Long, ch As String
Dim inQuote As Boolean
Dim idx As Long

ReDim result(0)
buf = ""
inQuote = False
idx = 0

For i = 1 To Len(s)
ch = Mid$(s, i, 1)

If ch = """" Then
If inQuote And Mid$(s, i + 1, 1) = """" Then
buf = buf & """"
i = i + 1
Else
inQuote = Not inQuote
End If

ElseIf ch = "," And Not inQuote Then
result(idx) = buf
idx = idx + 1
ReDim Preserve result(idx)
buf = ""

Else
buf = buf & ch
End If
Next

result(idx) = buf
ParseCSV = result
End Function


’----------------------------------------------------------------
Sub ImportCSV_UTF8_RFC4180_A8()

Dim folder As String
Dim fname As String
Dim fullpath As String
Dim f As Integer
Dim bin As String
Dim txt As String
Dim lines() As String
Dim r As Long
Dim cols As Variant

folder = Range("C1").Value
fname = Range("A1").Value & ".csv"
fullpath = folder & "\" & fname

'--- UTF-8 読み込み ---
f = FreeFile
Open fullpath For Binary As #f
bin = Space$(LOF(f))
Get #f, , bin
Close #f

txt = StrConv(bin, vbUnicode)

'--- 改行コードを統一 ---
txt = Replace(txt, vbCrLf, vbLf)
txt = Replace(txt, vbCr, vbLf)
lines = Split(txt, vbLf)

'--- A8 から表示 ---
r = 8

Dim line As Variant
For Each line In lines
If Len(line) > 0 Then

'★ RFC4180 CSV パース（ダブルクォート対応）
cols = ParseCSV(line)

Dim c As Long
For c = LBound(cols) To UBound(cols)
With Cells(r, c + 1)
.NumberFormat = "@"
.Value = cols(c)
End With
Next

r = r + 1
End If
Next

End Sub


'===========================================================
' RFC4180 準拠 CSV パーサ（ダブルクォート完全対応）
'===========================================================
Function ParseCSV(ByVal s As String) As Variant
Dim result() As String
Dim buf As String
Dim i As Long, ch As String
Dim inQuote As Boolean
Dim idx As Long

ReDim result(0)
buf = ""
inQuote = False
idx = 0

For i = 1 To Len(s)
ch = Mid$(s, i, 1)

If ch = """" Then
If inQuote And Mid$(s, i + 1, 1) = """" Then
buf = buf & """"
i = i + 1
Else
inQuote = Not inQuote
End If

ElseIf ch = "," And Not inQuote Then
result(idx) = buf
idx = idx + 1
ReDim Preserve result(idx)
buf = ""

Else
buf = buf & ch
End If
Next

result(idx) = buf
ParseCSV = result
End Function



’----------------------------------------------------------------
Sub ImportCSV_UTF8_NoGarble_KeepLeadingZeros()

Dim folder As String
Dim fname As String
Dim fullpath As String
Dim f As Integer
Dim txt As String
Dim lines() As String
Dim line As Variant
Dim r As Long, c As Long
Dim cols() As String

folder = Range("C1").Value
fname = Range("A1").Value & ".csv"
fullpath = folder & "\" & fname

'UTF-8 読み込み（Excelに任せない）
f = FreeFile
Open fullpath For Binary As #f
txt = Space$(LOF(f))
Get #f, , txt
Close #f

'UTF-8 → Unicode 変換（文字化け防止）
txt = StrConv(txt, vbUnicode)

'行分割
lines = Split(txt, vbCrLf)

'★ 表示開始行を A8 に変更
r = 8

For Each line In lines
If Len(line) > 0 Then
cols = Split(line, ",")
For c = 0 To UBound(cols)

'★ 先頭ゼロ保持のためテキスト形式を強制
With Cells(r, c + 1)
.NumberFormat = "@"
.Value = cols(c)
End With

Next
r = r + 1
End If
Next

End Sub



’----------------------------------------------------------------
Sub ImportCSV_UTF8_AsText_Safe()

Dim folder As String
Dim fname As String
Dim fullpath As String
Dim wbCSV As Workbook

folder = Range("C1").Value
fname = Range("A1").Value & ".csv"
fullpath = folder & "\" & fname

'UTF-8 で CSV を別ブックとして開く（既存セルは絶対に壊れない）
Workbooks.OpenText _
Filename:=fullpath, _
Origin:=65001, _
DataType:=xlDelimited, _
Comma:=True, _
TextQualifier:=xlTextQualifierDoubleQuote, _
FieldInfo:=Array(1, 2)   '全列テキスト

Set wbCSV = ActiveWorkbook

'A6 以降を更新（A1〜A5 は絶対に触らない）
ThisWorkbook.ActiveSheet.Range("A6").Resize( _
wbCSV.Sheets(1).UsedRange.Rows.Count, _
wbCSV.Sheets(1).UsedRange.Columns.Count _
).Value = wbCSV.Sheets(1).UsedRange.Value

'CSV ブックを閉じる
wbCSV.Close False

End Sub