vbaの1つのセル内の改行文字を1行ずつ取得したいです

VBAについて質問です。
1つのセル内にある改行文字列を、1行ずつ取得したいのですがうまく行きません。
ネットでも検索していろいろ試しましたが、一度も取得できずでした。

想定動作としては、
「Sheet2」A列にある文字を1行ずつ、「Sheet3]A,B,Cとセル指定をして取得したいです。
下記のコードではCSVのずれを防ぐために改行文字を工夫してCSV読み取り、シート出力をしております。こちらが原因なのでしょうか。
このコードを書くのにもかなり時間がかかり勉強不足のため理解ができておりません。
方法が見つからず苦戦しております。
ご教示いただければ幸いです。

Public Const charset = "UTF-8"
Public Const BR = vbLf

Sub csv_import2()
　　 targetsheet =  Thisworkbook.Worksheets("sheet2")
    file_path = Worksheets("sheet1").Range("C3").Value
    Debug.Print (file_path)
    
    ' ファイル読み込み
    MsgBox "CSVデータを選択してください"
    Dim buf As String, Target As String, i As Long
    Dim records As Variant, items As Variant, j As Long
    Dim Csv_Import_File  ' Excelファイルに取り込むCSVファイルの名前を入れ込む変数
    Csv_Import_File = Application.GetOpenFilename("CSVファイル,*.csv")  ' CSVファイルを選択する
    
    
    With CreateObject("ADODB.Stream")
        .charset = charset
        .Open
        .LoadFromFile Csv_Import_File
        buf = .ReadText
        .Close
        records = Split(buf, "#")
        headers = Split(records(0), ",")
        
        ' header書き出し
        For j = 0 To UBound(headers)
            Worksheets(targetsheet).Cells(1, j + 1).Value = headers(j)
        Next j
        
        For i = 1 To UBound(records)
            items = Split(records(i), ",")
            For j = 0 To UBound(items)
            If j = 0 And i <> 0 Then
                Worksheets(targetsheet).Cells(i + 1, j + 1).Value = "#" + items(j)
            Else
                Worksheets(targetsheet).Cells(i + 1, j + 1).Value = Replace(items(j), """", "")
            End If
            Next j
            Call write_target(i, items, headers)
        Next i
    End With
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(targetsheet)
 
    Call writeCsv(ws, ws.Range("A1"))
End Sub

こちらのコードもある方からご教示いただいたのですがエラーが出て動かないです。

Sub Sample()
Sheets(Sheet3).Range("A2").Value = Split(Sheets(Sheet2).Range("A1").Value, vbLf)(0)
Sheets(Sheet3).Range("B2").Value = Split(Sheets(Sheet2).Range("A1").Value, vbLf)(1) '//エラー　インデックスが有効でない
Sheets(Sheet3).Range("C2").Value = Split(Sheets(Sheet2).Range("A1").Value, vbLf)(2)
End Sub

Sgeet1にCSVデータ出力
![]

Sheet3にSheet1から取得したデータを書き出す

meg_

2021/09/19 09:57

2つの画像はどういうものでしょうか？（上は元データですか？下は何でしょうか？？）

dmg

2021/09/19 10:30

説明が足りず申し訳ございません。上が元データで、下がコード動かしたときの希望結果です。

meg_

2021/09/19 11:11

3行目のA列とB列が同一内容なのはどういうロジックでしょうか？質問に説明を追記してください。

dmg

2021/09/19 11:43

>3行目のA列とB列が同一内容なのはどういうロジックでしょうかすみません画像のお話でしょうか？配送日と配送時間のことでしょうか…？見当違いであれば申し訳ございません。

meg_

2021/09/19 12:04

> すみません画像のお話でしょうか？はい。下の画像です。 > 配送日と配送時間のことでしょうか…？いいえ。A3セルとB3セルのことです。

dmg

2021/09/19 12:53

度々申し訳ございません。私の不手際です。画像を差し替えましたので、再度ご確認いただけますと幸いです。

meg_

2021/09/19 13:05

> Sheets(Sheet3).Range("B2").Value = Split(Sheets(Sheet2).Range("A1").Value, vbLf)(1) '//エラー　インデックスが有効でない何故上記エラーが発生するのかが分からないということでしょうか？ Splitの使い方と配列についての理解が不足しているかと思われます。 http://officetanaka.net/excel/vba/tips/tips62.htm等で確認なさってください。それでも不明点があればコメントください。

dmg

2021/09/19 15:37

おっしゃる通り、私の理解不足です。理解ができるように勉強いたします。ありがとうございました。

行動規範の内容に同意します

回答2件

ベストアンサー

質問の説明や画像に矛盾点が目につきますが、それは忖度して、

Sheet2

として、

vba
1Public Sub Sample()
2    Dim sh2 As Worksheet
3    Set sh2 = Worksheets("Sheet2")
4    Dim sh3 As Worksheet
5    Set sh3 = Worksheets("Sheet3")
6    
7    Dim lastRow As Long
8    lastRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row
9    Dim rng  As Range
10    Set rng = sh2.Range("A2:A" & lastRow)
11    
12    Dim r As Long
13    For r = 2 To lastRow
14        Dim ary
15        ary = Split(sh2.Cells(r, 1).Value, vbLf)
16        sh3.Cells(r, 1).Resize(, UBound(ary) + 1).Value = ary
17    Next
18End Sub