CSVファイル内の複数レコードを取得したいが１レコード（１対のヘッダと値）しか取得できない

前提・実現したいこと

取込ボタン押下時に、フォルダに格納されているCSVファイルを選択し、CSVファイル内のデータ（項目名とデータ）を取得したいのですが、CSVファイルに複数レコード存在する場合に１レコードしか取得できません。
（取得できているのかもしれませんが、取得シートに１レコード（１対のヘッダと値）しか表示されません。）
複数レコードを取得するためにはどのように修正すべきかご教授いただけませんでしょうか。
また、複数レコードが取得できる場合に、取得できるレコード数に上限を儲けたい場合（レコードが６件以上ある場合は、５レコードまでしか取得しない、など）はどのように機能追加したらよろしいでしょうか。

例えば、以下のデータがCSVファイルに格納されている場合に、IDが01～05のレコードのみ取得したいです。（ID:06は取得しない。）

ID Name Address Age
01 Sato Tokyo 30
02 Kato Chiba 40
03 Ito Nara 25
04 Suzuki Kyoto 35
05 Kimura Shiga 45
06 Tanaka Akita 50

アドバイスをいただけませんでしょうか。
乱文で申し訳ございません。
どうぞ、よろしくお願いいたします。

発生している問題・エラーメッセージ

CSVファイルに複数レコードがある場合でも、１レコードしか取得できない

### 該当のソースコード
Sub 取込_Before_Click()

	Dim wsData As Worksheet
	Set wsData = Worksheets("取込")

	' 前に設定した値をクリア
	wsData.Range("A1:Z1000").ClearContents

	Dim arrayPath As Variant
	Dim intFree As Integer
	Dim strRec As String
	Dim strSplit() As String
	Dim intColCount As Integer
	Dim intRowCount As Integer

	'ダイアログから複数のブックを選択し、配列にパスを格納する
	arrayPath = Application.GetOpenFilename("CSVファイル(*.csv), *.csv", MultiSelect:=True)

	If IsArray(arrayPath) Then

		Application.ScreenUpdating = False

		Dim intCurrentCol As Integer

		Dim i As Integer

		For i = 1 To UBound(arrayPath)

			Dim j As Long, k As Long

			'空番号を取得
			intFree = FreeFile

			'CSVファイルをオープン
			Open arrayPath(i) For Input As #intFree

			j = 0
			k = 0

			Do Until EOF(intFree)
				Line Input #intFree, strRec
				j = j + 1
				intRowCount = intRowCount + 1
				strSplit = Split(strRec, ",")

				For k = 0 To UBound(strSplit)
					wsData.Cells(j, intColCount + k + 1) = strSplit(k)
				Next
			Loop
			
			intColCount = intColCount + UBound(strSplit) + 2


			Close #intFree
		Next i

		'読み込んだ内容をコピーして貼り付ける
		Dim copyRange As Range
		Set copyRange = wsData.Range(wsData.Cells(1, 1), wsData.Cells(intRowCount, intColCount))

		copyRange.Copy

		'読み込んだデータの下に行列入れ替えて貼り付ける
		wsData.Cells(intRowCount + 1, 1).PasteSpecial xlPasteValues, Transpose:=True

		'コピー元の値をすべてクリアする
		opyRange.ClearContents

		'クリアした空き行を詰める
		wsData.Range("1:" & intRowCount).Delete Shift:=xlUp

		'選択状態を解除
		wsData.Activate
		wsData.Range("A1").Select

		Application.ScreenUpdating = True

		Worksheets("Before").Range("B2:C1000").ClearContents

		Worksheets("取込").Range("A1:B1000").Copy
		Worksheets("Before").Range("B2").PasteSpecial Paste:=xlPasteValues

		wsData.Range("A1:Z1000").ClearContents

	End If

	Worksheets("フォーマット").Activate
	Worksheets("フォーマット").Select

End Sub

ソースコード

radames1000

2020/09/24 06:51

該当のソースコードが```で囲まれていないので修正してくださいね。

Usirow

2020/09/24 08:06 編集

1レコードしか読めないというのはどの段階でのことを言っているのでしょうか？コピペして動かしましたが、csvファイルを読む部分では問題なく読み込んでいます（コードの是非はとりあえず置いておきますしかし、最後にBeforeシートに張り付ける際に2列（A1:B1000）しかコピーしていないので、どれだけ読み込んでもヘッダーとレコード一つしか残りません。ここのことを仰っているのでしょうか？