エクセルで特定フォルダ内に三つcsvファイルがあり 、一つのエクセルファイル内にそれぞれ、三つのシー

エクセルで特定フォルダ内に三つcsvファイルがあり
、一つのエクセルファイル内にそれぞれ、三つのシートとして読み込みしたいと思いますが、上手くいきません。

解決案が分かられる方おられましたら、教えて下さい

No.1 回答者： WindFaller 回答日時： 2017/02/20 19:16

VBカテゴリにありましたね。

ちょっと曖昧な質問でしたので、お答えしにくい部分がありました。それは、1つのCSVファイルを、1つのシートに入れるというこということができるとも読めます。そして、３つのCSVファイルを、一気に3つのシートに入れるということが、うまく行きません、ということですと、一体、どこまで出来ているのだろうか、疑問が生じてしまいます。

確かに、3つを一気にシートにインポートすることは難しいにしても、１つずつ入れるなら、それでも良いような気がします。

本来、3つを一気にいれるということは、4つや5つもあるとも取れます。シートの制約やシートを加えること、データを入れるシートは左端シートから右隣に移っていくことなど、様々な約束事が必要になってしまいます。それらをこちらで勝手に決めてしまいました。シートにはデータが何もないことを条件にしています。

以下はサンプルです。

'//

Sub OpenCSVimport()
　Dim Fnames As Variant
　Dim fNum As Integer
　Dim shCnt As Integer, cnt As Integer
　Dim fn As Variant
　Dim lngCnt As Long
　Dim TextLine As String
　Dim myArray
　ThisWorkbook.Activate
　Dim myPath As String
　Dim dif As Integer
　
　myPath = "C:\Users\Test1\"　末尾は、￥で締めてください。
　ChDir myPath
　Fnames = Application.GetOpenFilename("CSVファイル,*.csv", , "CSV_Select", , True) 'MultiSelect OK
　If VarType(Fnames) = vbBoolean Then MsgBox "キャンセルされました。": Exit Sub
　
　shCnt = UBound(Fnames) 'ファイルを選んだ数
　cnt = 1
　Worksheets(1).Select '左端に移動
　dif = shCnt - Worksheets.Count
　Do
　　With ActiveSheet
　　　If Application.CountA(.UsedRange.Cells) > 0 Then
　　　　MsgBox "シートにデータがあるように思われます。" & vbCrLf & _
　　　　"データのないシートを使ってください。", vbExclamation
　　　　Exit Sub
　　　End If
　　　If cnt >= shCnt Then
　　　　Exit Do
　　　　Else
　　　　On Error Resume Next
　　　　.Next.Select
　　　　If Err.Number = 91 Then
　　　　If MsgBox("シートが不足していますから" & dif & "枚加えます。", vbOKCancel) = vbCancel Then Exit Sub
　　　　　Worksheets.Add After:=ActiveSheet, Count:=dif
　　　　End If
　　　　On Error GoTo 0
　　　End If
　　　cnt = cnt + 1
　　End With
　Loop
　cnt = 0
　Worksheets(1).Select '左端に移動
　For Each fn In Fnames
　　With ActiveSheet
　　　fNum = FreeFile()
　　　Open fn For Input As #fNum
　　　Application.ScreenUpdating = False
　　　Do While Not EOF(fNum)
　　　　Line Input #fNum, TextLine
　　　　If Len(TextLine) > 1 Then
　　　　　lngCnt = lngCnt + 1
　　　　　myArray = Split(TextLine, ",") 'デリミタは、「,」
　　　　　.Cells(lngCnt, 1).Resize(, UBound(myArray) + 1).Value = myArray
　　　　End If
　　　Loop
　　　Close #fNum
　　　Application.ScreenUpdating = True
　　　lngCnt = 1
　　　cnt = cnt + 1
　　　If cnt >= shCnt Then Exit For
　　　.Next.Select
　　End With
　Next fn
End Sub