CSV

質問

複数の定型フォームのCSVファイルを１エクセルファイルにして、エクセル上で集計まで行いたいと思っています。

今、「教えて！goo」から検索で、VBAを使って、CSVファイルをエクセルの１シートにまとめることはできたのですが、
・シート名を特定の名前にしたい
・同ファイル内の、既存の「TTL」というシート上で合計を表示させたい

のですが、シート名が定まらないので設定ができません。
どうか、設定方法を教えてください。

VBA式は以下のとおり
↓↓↓
Dim MyObj As Object
Dim MyFol As String
Dim MyFnm As String
Dim MyStr As String
Dim i As Long
Dim n As Long
Dim n1 As Long

'フォルダを選択する
Set MyObj = CreateObject("Shell.Application") _
.BrowseForFolder(0, "SelectFolder", 0)
'選択なければ処理を抜ける
If MyObj Is Nothing Then Exit Sub
MyFol = MyObj.self.Path & "\"
MsgBox MyFol & "を処理します。"
Set MyObj = Nothing
Application.ScreenUpdating = False
'ThisWorkbookにシートを追加して処理
With Sheets.Add
'Dir関数を使って指定フォルダ内csvファイルを順次処理
MyFnm = Dir(MyFol & "*.csv")
Do Until Len(MyFnm) = 0&
i = i + 1
'データエリアを取得してセット先を変更
n = IIf(n = 0, 1, n + n1)
'外部データ取り込みを利用
With .QueryTables.Add(Connection:="TEXT;" & MyFol & MyFnm, _
Destination:=.Range("B" & n))
.AdjustColumnWidth = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileCommaDelimiter = True
.Refresh False
n1 = .ResultRange.Rows.Count
.Parent.Names(.Name).Delete
.Delete
End With
'ファイル名をA列にセット
.Range("A" & n).Resize(n1).Value = MyFnm
'次のファイルへ
MyFnm = Dir()
Loop
End With
If i > 0 Then
MyStr = i & "個のファイルを処理しました。"
Else
'検索結果が０なら
MyStr = "検索条件を満たすファイルはありません。"
End If
Application.ScreenUpdating = True
MsgBox MyStr

回答No.2

Wendy02 · ベストアンサー

こんにちは。

これは、キーワードを見つけたら、その次のキーワードの直前までをインポートします。

.BrowseForFolder(0, "フォルダを選んだください。", 0, 5)
と、5を入れることによって、My Documents フォルダになります。

If InStr(1, LineBuf, KEYWORD, vbBinaryCompare) >

キーワードの文字比較は、BynaryCompare ですから、全角、半角、大文字、小文字を区別しますが、もし、その部分を、一緒にするには、vbTextCompare モードというものがあります。
なお、.csv ファイルは、現在は、あくまでも、「,(コンマ切り）」のみの対応です。

Sub ImportCSV()
　　Dim myShell As Object
　　Dim myFol As String
　　Dim Fn As String
　　Dim Fno As Integer
　　Dim LineBuf As String
　　Dim ArBuf As Variant
　　Dim EndCol As Integer
　　Dim n As Long
　　Dim k As Long
　　Dim flgKey As Integer
　　'キーワード
　　Const KEYWORD As String = "Ａ１"

　　Set myShell = CreateObject("Shell.Application") _
　　　 .BrowseForFolder(0, "フォルダを選んだください。", 0, 0)　'最後の0を　5にすると、My Documents
　　　 If myShell Is Nothing Then Exit Sub
　　With myShell
　　　　If .Self.Path = "" Then Exit Sub
　　　　myFol = .Self.Path & "\"
　　　　If MsgBox(myFol & vbCrLf & "上記フォルダを処理します。よろしいですか？", vbInformation + vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　End If
　　End With
　　'シートのチェック
　　On Error Resume Next
　　Application.Goto Worksheets("TTL").Range("A1")
　　If Err.Number = 0 Then
　　　　　 If MsgBox("既に、'TTL'　シートは存在しています。" & vbCrLf _
　　　　　　& "シートのデータを削除しますか？", vbInformation + vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　　 Else
　　　　　　　ActiveSheet.Cells.Clear
　　　　　 End If
　　　　 Err.Clear
　　Else
　　　Worksheets.Add
　　　ActiveSheet.Name = "TTL"
　　End If

　 On Error GoTo 0
　 'インポート
　 Application.ScreenUpdating = False
　　With ActiveSheet
　　　　Fn = Dir(myFol & "*.csv") 'ワイルドカード
　　　　n = 1
　　　　Do Until Len(Fn) = 0
　　　　　　Fno = FreeFile
　　　　　　Open Fn For Input As #Fno
　　　　　　　 flgKey = 0
　　　　　　Do While Not EOF(Fno)
　　　　　　　　Line Input #Fno, LineBuf
　　　　　　　　If InStr(1, LineBuf, KEYWORD, vbBinaryCompare) > 0 And flgKey = 0 Then
　　　　　　　　　 flgKey = 1
　　　　　　　　ElseIf InStr(1, LineBuf, KEYWORD, vbBinaryCompare) > 0 And flgKey = 1 Then
　　　　　　　　　 flgKey = 2
　　　　　　　　End If
　　　　　　　　If flgKey = 1 Then
　　　　　　　　　　ArBuf = Split(LineBuf, ",")
　　　　　　　　　　EndCol = UBound(ArBuf)
　　　　　　　　　　k = k + 1
　　　　　　　　　　'2列目に出力
　　　　　　　　　　ActiveSheet.Cells(k, 2).Resize(, EndCol) = ArBuf
　　　　　　　　ElseIf flgKey = 2 Then
　　　　　　　　　　Exit Do
　　　　　　　　End If
　　　　　　Loop
　　　　　　If k > n Then
　　　　　　　'ファイル名の書き出し
　　　　　　　.Range("A" & n).Resize(k - n + 1).Value = Fn
　　　　　　　 n = k + 1
　　　　　　End If
　　　　　　Fn = Dir()
　　　　Loop
　　End With
　　　　Application.ScreenUpdating = True

End Sub

回答No.3

Wendy02

#2のコードの修正をお願いします

　　　End If
　　End With　　　'おそらく22行目
Set myShell = Nothing
　　'シートのチェック

その22行目の後に、Set myShell = Nothing
を入れて、解放させておいてください。ただし、特に、それを入れなくても支障はないはずですが、置き忘れは、あまりコード的に良くありません。

お礼

ご対応ありがとうございました。

これからどんどん改良していきたいと思います。accessの便利さに今ちょっと感動しています。

この問い合わせを完了させて頂きます。
ありがとうございました。

回答No.1

Wendy02

こんにちは。

あまり、他人のコードを細かく調べるつもりはありませんが、

>・シート名を特定の名前にしたい

それは、単に、

With Sheets.Add
としているだけですから、
その後に、
ActiveSheet.Name = "○○○"

>・同ファイル内の、既存の「TTL」というシート上で合計を表示させたい

そのコードですと、最終行が出るはすですから、
TTL のシートに、

n の変数を再利用して、

Worksheets("TTL").Range("A1").FormulaLocal = "=SUM(○○○!B1:B" & n & ")"

とすればよいはずです。

お礼

できました。希望通りです。ありがとうございました。
即回答も助かりました。勉強になります・・・。
重ねて、ありがとうございました。