CSVファイルの読み込みVBA作成について

質問

初めまして。
色々インターネット等で検索して作成してみたのですが、
ここから先のプログラムが組めないので、
やり方を教えて頂けますと幸いです。

おそらくIf Elseで場合訳すると思うのですが、
上手くできてません。

下記、プログラムの概要です。
(1)フォルダを指定し、そのフォルダにある全てのCSVファイルを読み込む。
(2)CSVファイルを読み込む際には、「*.csv」の「*」部分をワークシート名とし、CSVファイルの内容をワークシートに書き込む。
例）「test.csv」の場合、ワークシート名は「test」になります。
(3)既にブックにワークシート名がある場合は上書き処理を行い、ない場合は新規に作成する。
例）既に「test」ワークシートがある場合は、内容の上書きを行います。
(4)ワークシートを追加する際は、今あるワークシートの最後に追加する。

下記に現在作ったプログラムを記載します
---------------------------------
Sub csvRead()
Dim FoldPath As String
Dim f
Dim ch1 As Long
Dim r As Long
Dim textLine As String
Dim csvLine() As String
Dim i As Long
Dim FSO
Dim folderSelect As Object

Set folderSelect = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)
If Not folderSelect Is Nothing Then
FoldPath = folderSelect.Self.Path 'フォルダ選択
End If

Set FSO = CreateObject("Scripting.FileSystemObject")

i = Worksheets.Count '現在のワークシート数を格納

For Each f In FSO.GetFolder(FoldPath).Files
If StrConv(Right(f.Path, 4), vbLowerCase) = ".csv" Then
ch1 = FreeFile
Open f.Path For Input As #ch1
r = 1

Worksheets.Add after:=Worksheets(i)
With ActiveSheet
.Name = Left(f.Name, Len(f.Name) - 4)
Do While Not EOF(ch1)
Line Input #ch1, textLine
If textLine <> "" Then
csvLine() = Split(textLine, ",")
.Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()
End If
r = r + 1
Loop
End With
i = i + 1

Close #ch1
End If
Next
End Sub

回答No.4

end-u · ベストアンサー

カンマ区切りのデータ状態によっては[外部データの取り込み]を使うとラクな場合があります。
参考程度ですが。
Sub try()
　　Dim folderSelect As Object
　　Dim ws　　　　　 As Worksheet
　　Dim foldPath　　 As String
　　Dim f　　　　　　As String
　　Dim chk　　　　　As String
　　Dim i　　　　　　As Long

　　Set folderSelect = CreateObject("Shell.Application"). _
　　　　　　　　　　　 BrowseForFolder(0, "フォルダを選択してください", 0)
　　If folderSelect Is Nothing Then Exit Sub
　　Application.ScreenUpdating = False
　　foldPath = folderSelect.Self.Path & "\"
　　i = Worksheets.Count
　　f = Dir(foldPath & "*.csv")

　　Do Until Len(f) = 0&
　　　　chk = Left$(f, Len(f) - 4)
　　　　Set ws = Nothing
　　　　On Error Resume Next
　　　　Set ws = Sheets(chk)
　　　　On Error GoTo 0
　　　　If ws Is Nothing Then
　　　　　　Set ws = Worksheets.Add(after:=Worksheets(i))
　　　　　　ws.Name = chk
　　　　　　i = i + 1
　　　　Else
　　　　　　ws.UsedRange.ClearContents
　　　　End If
　　　　With ws.QueryTables.Add(Connection:="TEXT;" & foldPath & f, _
　　　　　　　　　　　　　　　　Destination:=ws.Cells(1))
　　　　　　.AdjustColumnWidth = False
　　　　　　.TextFilePlatform = xlWindows
　　　　　　.TextFileStartRow = 1
　　　　　　.TextFileCommaDelimiter = True
　　　　　　.Refresh False
　　　　　　.Parent.Names(.Name).Delete
　　　　　　.Delete
　　　　End With
　　　　f = Dir()
　　Loop

　　Application.ScreenUpdating = True
　　Set ws = Nothing
　　Set folderSelect = Nothing
End Sub

お礼

end-uさん、ありがとうございます。
こちらのソースコードも試しましたところ、
無事求める動作をすることができました。

＞カンマ区切りのデータ状態によっては[外部データの取り込み]を使うとラクな場合があります。

とありますが、
カンマ区切りのデータ状態とは具体的にどのようなものが
想定されるのでしょうか。

勉強不足で申し訳ございませんが、ご教示頂けますと幸いです。

回答No.5

end-u

ご提示のSub csvRead()で問題なければ今のところは大丈夫なのでしょう。
フィールド内で『1,234』などの桁区切りデータを扱いたい場合、
引用符『"』などで括ります。

0,0,0,0,"1,234",0,...

などのように。
ExcelシートをCSVで保存するとそうなりますね。
何かのシステムからCSVデータを生成したりする時に、
特定フィールドが『"』で括られるものもあったりします。

そのようなカンマ区切りファイルを読み込む時には
単純に","で分割するわけにはいきませんから、
QueryTableを使うとラクですよ、という意味です。
"1,234"などのデータが無いという事が担保されているなら
あまり考えなくて良いと思います。

ただ、元々Excelに備わってる機能ですからね。処理も速いですし。
あくまで『参考程度ですが。』です。

お礼

end-uさん、早速のご回答ありがとうございます。
丁寧な説明で私にも理解できました。

今回取り扱うデータで今のところ
end-uさんがおっしゃるようなカンマ区切りデータはないのですが
その辺りも考慮する必要がありますよね。

再度データを見直し、対応したく思います。
ありがとうございます。

回答No.3

Wendy02

#2のコードに補足があります。

'-------------------------------------------
'最初のデータ型の宣言の後に、2行を加えます。
Dim myCur As String　　'←
myCur = CurDir　　'←
'------------------------------------------- この手前に、
　　With Application.FileDialog(msoFileDialogFolderPicker)

'=========================================
'最後1行を加えます。
　　ChDir myCur　'←
End Sub

これを入れないと、カレント・ディレクトリが変わってしまいます。

お礼

Wendy02さん、早速のご回答ありがとうございます。
ご提示頂きましたソースコードを試しましたところ、
無事求める動作をすることができました。
本当にありがとうございます。

Wendy02さんご提示のソースコードは
今の私では分からない部分もありますので
それをベースに更なる勉強に励みたいと思います。

回答No.2

Wendy02

こんにちは。

全体的に危ない部分がありますね。それを今言ってもしょうがないような気がします。それは、トラブルがあってから考えてもよいと思います。

コードとしてのミスはあるとしても、
例：.Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()　'←これはミス　(Cellsのピリオドが抜けています）

>(3)既にブックにワークシート名がある場合は上書き処理を行い、ない場合は新規に作成する。
この部分ができていないのではありませんか？

どちらかといと、最初から組み立てのやり直しですね。
なぜ、ここまで変えなくてはならないのとか、思う人もいるかもしれませんが、せっかくのVBAで、VBSではありませんから、VBAで使えるものは使ったほうが良いと思います。

なお、shNameChecker関数サブ・プロシージャの内容は、もう少しきれいな書き方があるような気がしますが、臨時でこしらえたもので、実にコード的に見苦しいです。元のcsvReadRev内でもよかったのですが、見やすさを考えました。
'-------------------------------------------
Sub CsvReadRev()
　　Dim FoldPath As String
　　Dim FileName As String
　　Dim shName As String
　　Dim fName As String
　　Dim ch1 As Long
　　Dim r As Long
　　Dim textLine As String
　　Dim csvLine() As String
　　Dim FSO
　　Dim sh As Worksheet
　　Dim folderSelect As Object

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Show
　　　　FoldPath = .SelectedItems(1)
　　End With
　　FileName = Dir(FoldPath & "\*" & ".csv")
　　Do While FileName <> ""
　　　　shName = Replace(Mid$(FileName, InStrRev(FileName, "\") + 1), ".csv", "", , , 1)
　　　　If shNameChecker(shName) Then
　　　　　　Set sh = Worksheets(shName)
　　　　Else
　　　　　　Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　sh.Name = shName
　　　　End If
　　　　ch1 = FreeFile()

　　　　Open FileName For Input As #ch1
　　　　With sh
　　　　　　r = 1
　　　　　　Application.ScreenUpdating = False
　　　　　　Do While Not EOF(ch1)
　　　　　　　　Line Input #ch1, textLine
　　　　　　　　If textLine <> "" Then
　　　　　　　　　　csvLine() = Split(textLine, ",")
　　　　　　　　　　.Range(.Cells(r, 1), .Cells(r, UBound(csvLine()) + 1)) = csvLine()
　　　　　　　　End If
　　　　　　　　r = r + 1
　　　　　　Loop
　　　　　　Application.ScreenUpdating = True
　　　　End With
　　　　Close #ch1
　　　　Set sh = Nothing
　　　　FileName = Dir()
　　Loop
End Sub

Function shNameChecker(strTxt As String)
Dim buf As Variant
Dim flg As Boolean
　flg = False
　With ActiveWorkbook
　　On Error Resume Next
　　buf = Empty
　　buf = .Worksheets(strTxt).Name
　　Err.Clear
　　If VarType(buf) = vbString Then
　　　　flg = True
　　Else
　　　　flg = False
　　End If
　　On Error GoTo 0
　End With
　 shNameChecker = flg
End Function

回答No.1

bakakyatap

＞ここから先のプログラムが組めないので、

ここから先とは、どこから先ですか？　

Worksheets.Add after:=Worksheets(i)

まで来ているので、内容が間違っている事に目をつぶったとして、何をしたいのかつかめません。

補足

こちらの説明不足で申し訳ございません。
お聞きしたい部分は、上書き処理の部分です。