あ

Sub ImportFilesToSpecifiedColumns_UTF8()
    Dim ListFilePath As String
    Dim LineFromList As String
    Dim ColumnLetter As String
    Dim FilePath As String
    Dim FileName As String
    Dim SheetName As String
    Dim LineText As String
    Dim LineNum As Long
    Dim ws As Worksheet
    Dim i As Long
    Dim ThisWB As Workbook
    Dim ListLines As Collection

    ' ? リストファイルのパスをここで指定
    ListFilePath = "C:\Users\my_ch\Desktop\list.txt"  ' ← あなたのパスに変更してください

    If Dir(ListFilePath) = "" Then
        MsgBox "リストファイルが見つかりません：" & vbCrLf & ListFilePath, vbCritical
        Exit Sub
    End If

    Set ThisWB = ThisWorkbook
    Set ListLines = New Collection

    ' --- リストファイルを読み込む（Shift-JIS 前提）
    Dim FileNum As Integer
    On Error GoTo ListReadError
    FileNum = FreeFile
    Open ListFilePath For Input As #FileNum
    Do While Not EOF(FileNum)
        Line Input #FileNum, LineFromList
        If Trim(LineFromList) <> "" Then
            ListLines.Add Trim(LineFromList)
        End If
    Loop
    Close #FileNum
    On Error GoTo 0

    ' 各行を処理
    Application.ScreenUpdating = False

    For i = 1 To ListLines.Count
        LineFromList = ListLines(i)

        If InStr(LineFromList, ",") = 0 Then GoTo NextLine

        ColumnLetter = LCase(Trim(Left(LineFromList, InStr(LineFromList, ",") - 1)))
        FilePath = Trim(Mid(LineFromList, InStr(LineFromList, ",") + 1))

        FileName = Mid(FilePath, InStrRev(FilePath, "\") + 1)
        If InStrRev(FileName, ".") > 0 Then
            SheetName = Left(FileName, InStrRev(FileName, ".") - 1)
        Else
            SheetName = FileName
        End If

        ' シート名の無効文字を除去
        Dim InvalidChars As Variant
        InvalidChars = Array("/", "\", "[", "]", "*", "?", ":", "'")
        Dim ch As Variant
        For Each ch In InvalidChars
            SheetName = Replace(SheetName, ch, "_")
        Next ch

        ' シートを取得または作成
        Dim SheetExists As Boolean
        SheetExists = False
        Dim s As Worksheet
        For Each s In ThisWB.Sheets
            If s.Name = SheetName Then
                Set ws = s
                SheetExists = True
                Exit For
            End If
        Next s

        If Not SheetExists Then
            Set ws = ThisWB.Sheets.Add
            ws.Name = SheetName
        End If

        ' 対象列を取得
        Dim ColumnNumber As Long
        ColumnNumber = Asc(LCase(ColumnLetter)) - Asc("a") + 1
        If ColumnNumber < 1 Or ColumnNumber > 26 Then
            MsgBox "不正な列指定: '" & ColumnLetter & "'", vbExclamation
            GoTo NextLine
        End If

        ' 列クリア
        ws.Columns(ColumnNumber).ClearContents

        ' --- UTF-8対応読み込み（ADODB.Stream）
        Dim stream As Object
        Set stream = CreateObject("ADODB.Stream")
        stream.Charset = "utf-8"
        stream.Open
        stream.LoadFromFile FilePath
        LineText = ""
        LineNum = 1

        Do Until stream.EOS
            LineText = stream.ReadText(-2) ' -2 = 読み取り行単位
            ws.Cells(LineNum, ColumnNumber).Value = LineText
            LineNum = LineNum + 1
        Loop

        stream.Close
        Set stream = Nothing

NextLine:
        Err.Clear
    Next i

    Application.ScreenUpdating = True
    MsgBox "すべてのファイルを処理しました。", vbInformation
    Exit Sub

ListReadError:
    MsgBox "リストファイルが読み込めませんでした。", vbCritical
    If FileNum > 0 Then Close #FileNum
End Sub