月: 2024年7月

Option Explicit

Sub ImportCsvToRandomNameSheets()

Dim folderPath As String
Dim fd As FileDialog
Dim fileName As String
Dim fullPath As String

Dim baseName As String
Dim parts() As String
Dim sheetName As String

Dim wbCsv As Workbook
Dim wsCsv As Worksheet
Dim wsTarget As Worksheet

Dim lastRow As Long
Dim nextCol As Long

'=== CSVフォルダを選択 ===
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .Title = "CSVファイルが入っているフォルダを選択してください"
    If .Show <> -1 Then
        MsgBox "キャンセルされました。", vbInformation
        Exit Sub
    End If
    folderPath = .SelectedItems(1)
End With

If Right(folderPath, 1) <> "\" Then
    folderPath = folderPath & "\"
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'=== フォルダ内のCSVファイルを順番に処理 ===
fileName = Dir(folderPath & "*.csv")

Do While fileName <> ""

    fullPath = folderPath & fileName

    ' 拡張子を除いたファイル名（例: Kyoten020_L9bXw_config_001）
    baseName = Left(fileName, InStrRev(fileName, ".") - 1)

    ' "_" で分割 → 0:Kyoten020, 1:L9bXw, 2:config, 3:001
    parts = Split(baseName, "_")

    ' 安全のため要素数チェック
    If UBound(parts) >= 1 Then

        sheetName = parts(1)   ' 2番目の部分がシート名 (例: L9bXw)

        On Error Resume Next
        Set wsTarget = ThisWorkbook.Worksheets(sheetName)
        On Error GoTo 0

        If Not wsTarget Is Nothing Then

            '=== CSVファイルを開く ===
            Set wbCsv = Workbooks.Open(fileName:=fullPath, Local:=True)
            Set wsCsv = wbCsv.Worksheets(1)   ' CSVは通常1シートだけ

            ' CSV側の最終行（A列前提）
            lastRow = wsCsv.Cells(wsCsv.Rows.Count, "A").End(xlUp).Row

            '=== 貼り付け先シートの次の空き列を探す ===
            ' A1 が空なら 1列目を使用
            If IsEmpty(wsTarget.Cells(1, 1)) Then
                nextCol = 1
            Else
                ' 一番右の使用列を探して +1
                nextCol = wsTarget.Cells(1, wsTarget.Columns.Count).End(xlToLeft).Column + 1
            End If

            '=== 値を貼り付け（A列から縦にコピー） ===
            wsTarget.Range(wsTarget.Cells(1, nextCol), wsTarget.Cells(lastRow, nextCol)).Value = _
                wsCsv.Range("A1:A" & lastRow).Value

            ' CSVブックを閉じる（保存しない）
            wbCsv.Close SaveChanges:=False

        Else
            ' 対応するシートが存在しない場合はスキップ
            ' 必要なら MsgBox 等で通知してもOK
        End If

        ' オブジェクトの解放
        Set wsTarget = Nothing
        Set wsCsv = Nothing
        Set wbCsv = Nothing

    End If

    ' 次のファイルへ
    fileName = Dir()
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "取り込みが完了しました。", vbInformation

End Sub