Sub fileopen()
Dim FileNames As Variant
Dim fn As Variant
Dim SheetName As String
FileNames = Application.GetOpenFilename _
("CSV(*.csv),*.csv", MultiSelect:=True)
If VarType(FileNames) = vbBoolean Then Exit Sub
For Each fn In FileNames
' Worksheets.Add After:=Worksheets(Worksheets.Count)
SheetName = Dir(fn)
' ファイル名で新しいシート作成
Set NewWorkSheet = CreateWorkSheet(SheetName)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & fn, _
Destination:=Range("A1"))
.Name = ActiveSheet.Name
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileCommaDelimiter = True
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.UsedRange.QueryTable.Delete
Next fn
End Sub
Function CreateWorkSheet(WorkSheetName As String) As Worksheet
' 変数定義
Dim NewWorkSheet As Worksheet
Dim iCheckSameName As Integer
' ワークシートの作成
' ※一番最後に挿入
Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
' 同じ名前ワークシートが無いか確認
iCheckSameName = 0
For Each WS In Sheets
If WS.Name = WorkSheetName Then
MsgBox "ワークシート名:" + WorkSheetName + " この名前は既に使われています。"
iCheckSameName = 1
End If
Next
'同じ名前のワークシートがなければ
If iCheckSameName = 0 Then
NewWorkSheet.Name = WorkSheetName
Set CreateWorkSheet = NewWorkSheet
End If
End Function