| |
こんなかなあ？
Option Explicit
Public Sub DataRead()
Dim i As Long
Dim vntFileName As Variant
If Not GetReadFile(vntFileName, "D:\dai\448\Nx") Then
Exit Sub
End If
Application.ScreenUpdating = False
CSVRead vntFileName, _
Workbooks("ｃｈｅｃｋ.xls").Worksheets("0"), _
2, 1, ","
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1, _
Optional strDelim As String = ",")
'書き込み開始列（B列）
Const lngMinCol As Long = 1
'書き込み終了列（J列）
Const lngMaxCol As Long = 9
'書き込み開始行
Const lngStart As Long = 1
'書き込み終了行
Const lngEnd As Long = 150
Dim i As Long
Dim lngCount As Long
Dim dfn As Integer
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
Dim vntWrite As Variant
Dim lngNumb As Long
dfn = FreeFile
Open strFileName For Input As dfn
lngCount = 0
Do Until EOF(dfn)
Line Input #dfn, strLine
strRec = strRec & strLine
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
If blnMulti Then
strRec = strRec & vbLf
Else
lngCount = lngCount + 1
If lngStart <= lngCount And lngCount <= lngEnd Then
If UBound(vntField) >= lngMaxCol Then
lngNumb = lngMaxCol
Else
lngNumb = UBound(vntField)
End If
ReDim vntWrite(lngMinCol To lngMaxCol)
For i = lngMinCol To lngNumb
vntWrite(i) = vntField(i)
Next i
With wksWrite.Cells(lngRow, lngCol)
.Resize(, UBound(vntWrite) _
- LBound(vntWrite) + 1) = vntWrite
End With
lngRow = lngRow + 1
End If
strRec = ""
End If
Loop
Close #dfn
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As Variant
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = ""
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 04/12/12(日) 1:58 -
