ExcelシートにCSVファイルを読み込むVBA
ExcelシートにCSVファイルを読み込むVBA コードです。もちろんExcel標準機能で可能なんですがマウスワンクリックで終わらせたいと思ったのでCopilot AIに実装させました要件・UTF8ファイルに対応・ファイル名、フォルダーパスはアクティブシートのセルの情報を使用するファイル名→A1フォルダーパス→C1・読み込んだCSVの表示開始位置は、８行目（A８セル）からとする・文字の"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 NextEnd 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 = txtEnd 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 = resultEnd 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 NextEnd 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 = resultEnd 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 NextEnd 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 FalseEnd Sub
出産・子育て
ファッション
美容・コスメ
健康・ダイエット
生活・インテリア
料理・食べ物
ドリンク・お酒
ペット
趣味・ゲーム
映画・ＴＶ
音楽
読書・コミック
旅行・海外情報
園芸
スポーツ
アウトドア・釣り
車・バイク
パソコン・家電
そのほか
すべてのジャンル
